{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}

module Language.Del.Reader
    ( Language.Del.Reader.read
    , Form (DefForm, ImportForm)
    ) where

import qualified Data.ByteString.Char8 as BS
import qualified Data.Functor.Identity as Id
import qualified Data.Text as T
import           Language.Del.AST
import           Language.Del.CompileDefs
import           Language.Del.TypeTable
import           Network.HTTP.Req
import           Text.Parsec
import qualified Text.Parsec.Text as PT
import qualified Text.Parsec.Token as Token

data Form
    = DefForm T.Text Type [(T.Text, Type)] Expr
    | ImportForm (Either Name SourceUrl) T.Text

instance Show Form where
    show (DefForm n ret args body) = concat [
        "(", T.unpack n, ":", (show ret), " ",
        unwords $ map (\(a, t) -> T.unpack a ++ ":" ++ show t) args,
        ") -> ", show body]
    show (ImportForm (Left n) alias) = concat [
        "(#import ", T.unpack n, " -> ", T.unpack alias, ")"]
    show (ImportForm (Right url) alias) = concat [
        "(#import ", show url, " -> ", T.unpack alias, ")"]

lang :: Token.GenLanguageDef T.Text () Id.Identity
lang = Token.LanguageDef { Token.commentLine = ""
                         , Token.commentStart = "(*"
                         , Token.commentEnd = "*)"
                         , Token.nestedComments = False
                         , Token.identStart = letter
                         , Token.identLetter = alphaNum <|> oneOf "-"
                         , Token.opStart = oneOf "+-*/%^>=<$"
                         , Token.opLetter = oneOf "=" -- the only two-char ops are <= and >=
                         , Token.reservedNames = ["define"]
                         , Token.reservedOpNames = []
                         , Token.caseSensitive = True
                         }

lexer :: Token.GenTokenParser T.Text () Id.Identity
lexer = Token.makeTokenParser lang

parens   = Token.parens lexer
name     = Token.identifier lexer >>= return . T.pack
ws       = Token.whiteSpace lexer
reserved = Token.reserved lexer
lexeme   = Token.lexeme lexer
op       = Token.operator lexer >>= return . T.pack

typedname :: PT.Parser (T.Text, Type)
typedname = do
    n <- name
    _ <- char ':'
    t <- name
    return (n, NamedType t)

sign :: PT.Parser (DelNum -> DelNum)
sign = lexeme $ (char '-' >> return negate) <|> (char '+' >> return id) <|> return id

number :: PT.Parser Expr
number = do
    s <- sign
    nof <- Token.naturalOrFloat lexer
    return . Number . s $ case nof of
         Left int -> DelInt int
         Right double -> DelFloat double

apply :: PT.Parser Expr
apply = parens $ do
    hd <- expr
    rest <- many expr
    return $ Apply hd rest

ident :: PT.Parser Expr
ident = do
    n <- name
    x <- optionMaybe (char '.' >> name)
    case x of
         Nothing -> return (Id n)
         Just v  -> return (ScopedId n v)

exprNoSub :: PT.Parser Expr
exprNoSub = ident
            <|> (Id <$> op)
            <|> apply
            <|> number
            <?> "expression"

expr :: PT.Parser Expr
expr = do
    e <- exprNoSub
    option e (char '_' >> name >>= return . (Subscript e))

-- Parses a definition without the enclosing braces
def :: PT.Parser Form
def = do
    _ <- reserved "define"
    (n, ret) <- typedname
    args <- parens $ many typedname
    body <- expr
    return $ DefForm n ret args body

urlchars :: String
urlchars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" ++
           "-._~:/?#[]@!$&'()*+,;=`."

parseurl :: String -> Maybe SourceUrl
parseurl s =
    if take 5 s == "https"
       then case parseUrlHttps (BS.pack s) of
                 Just (url, _) -> Just $ HttpsSource url
                 Nothing -> Nothing
       else case parseUrlHttp (BS.pack s) of
                 Just (url, _) -> Just $ HttpSource url
                 Nothing -> Nothing

-- Parses an import without the enclosing braces
imports :: PT.Parser Form
imports = do
    _ <- reserved "import"
    src <- lexeme $ many1 (oneOf urlchars)
    alias <- name
    case parseurl src of
         Just url -> return $ ImportForm (Right url) alias
         Nothing -> case Text.Parsec.parse name "-" (T.pack src) of
                         Left _ -> fail ("import " ++ src ++
                                           " is neither a URL nor a name")
                         Right _ -> return $ ImportForm (Left $ T.pack src) alias

form :: PT.Parser Form
form = parens (def <|> imports)

top :: PT.Parser [Form]
top = ws *> many1 form

read :: T.Text -> Artifact [Form]
read t = case Text.Parsec.parse top "source" t of
              Left err -> Failure (ReadError err)
              Right exprs -> return exprs