{-# LANGUAGE OverloadedStrings #-}
module TW.Parser
    ( moduleFromText
    , moduleFromFile
    , makeModuleName
    )
where

import TW.Ast

import Data.Either
import Data.Maybe
import Control.Monad.Identity
import Data.Char
import Text.Parsec
import Network.HTTP.Types.Method
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import qualified Text.Parsec.Token as P

type Parser = Parsec T.Text ()

makeModuleName :: T.Text -> Either String ModuleName
makeModuleName inp =
    case runParser (parseModuleName <* eof) () "<input>" inp of
      Left err -> Left (show err)
      Right m -> Right m

moduleFromText :: FilePath -> T.Text -> Either String Module
moduleFromText file t =
    case runParser (parseModule <* eof) () file t of
      Left err -> Left (show err)
      Right m -> Right m


moduleFromFile :: FilePath -> IO (Either String Module)
moduleFromFile file =
    do input <- T.readFile file
       return $ moduleFromText file input

parseModule :: Parser Module
parseModule =
    do reserved "module"
       moduleName <- parseModuleName
       _ <- semi
       imports <- many parseImport
       tyDefs <- many ((Left <$> parseTypeDef) <|> (Right <$> parseApiDef))
       return $ Module moduleName imports (lefts tyDefs) (rights tyDefs)

parseModuleName :: Parser ModuleName
parseModuleName =
    lexeme $
    ModuleName <$> dotSep1 parseCapitalized

parseImport :: Parser ModuleName
parseImport =
    do reserved "import"
       m <- parseModuleName
       _ <- semi
       return m

parseApiDef :: Parser ApiDef
parseApiDef =
    do reserved "api"
       name <- identifier
       (headers, endpoints) <-
         braces $
         do headers <-
              optionMaybe $ try $ brackets (commaSep1 parseApiHeader) <* semi
            ep <- many parseApiEndpoint
            return (fromMaybe [] headers, ep)
       return (ApiDef (ApiName $ T.pack name) headers endpoints)

parseApiEndpoint :: Parser ApiEndpointDef
parseApiEndpoint =
    do name <- identifier
       reservedOp "="
       verbStr <- identifier
       verb <-
         case parseMethod (T.encodeUtf8 $ T.toUpper $ T.pack verbStr) of
           Left _ -> fail $ "Unknown http verb: " ++ verbStr
           Right v -> return v
       route <- parens (slashSep1 parseRouteComp)
       headers <- optionMaybe $ try $ brackets (commaSep1 parseApiHeader)
       reservedOp ":"
       req <- optionMaybe $ try (parseType <* reservedOp "->")
       resp <- parseType
       _ <- semi
       return
         ApiEndpointDef
         { aed_name = EndpointName $ T.pack name
         , aed_verb = verb
         , aed_headers = fromMaybe [] headers
         , aed_route = route
         , aed_req = req
         , aed_resp = resp
         }

parseApiHeader :: Parser ApiHeader
parseApiHeader =
    do name <- stringLiteral
       val <-
          (reservedOp "=" *> (ApiHeaderValueStatic <$> (T.pack <$> stringLiteral))) <|>
          pure ApiHeaderValueDynamic
       return (ApiHeader (T.pack name) val)

parseRouteComp :: Parser ApiRouteComp
parseRouteComp =
    ApiRouteStatic <$> (T.pack <$> stringLiteral) <|>
    ApiRouteDynamic <$> parseType

parseTypeDef :: Parser TypeDef
parseTypeDef =
    TypeDefEnum <$> parseEnumDef <|>
    TypeDefStruct <$> parseStructDef

parseDef :: (TypeName -> [TypeVar] -> [fld] -> def) -> String -> Parser fld -> Parser def
parseDef constr resName parseFields =
    do reserved resName
       name <- parseTypeName
       args <- parseTypeArgs
       fields <- braces $ many parseFields
       return $ constr name args fields

parseEnumDef :: Parser EnumDef
parseEnumDef = parseDef EnumDef "enum" parseEnumChoice

parseStructDef :: Parser StructDef
parseStructDef = parseDef StructDef "type" parseStructField

parseEnumChoice :: Parser EnumChoice
parseEnumChoice =
    do name <- parseChoiceName
       arg <- option Nothing (Just <$> parens parseType)
       _ <- semi
       return $ EnumChoice name arg

parseStructField :: Parser StructField
parseStructField =
    do name <- FieldName . T.pack <$> identifier
       reservedOp ":"
       ty <- parseType
       _ <- semi
       return $ StructField name ty

parseType :: Parser Type
parseType =
    TyVar <$> parseTypeVar <|>
    TyCon <$> parseQualTypeName <*> parseTyArgs
    where
      parseTyArgs =
          option [] $ angles $ commaSep1 parseType

parseTypeArgs :: Parser [TypeVar]
parseTypeArgs =
    option [] $
    angles $
    commaSep1 parseTypeVar

parseTypeVar :: Parser TypeVar
parseTypeVar = TypeVar . T.pack <$> identifier

parseTypeName :: Parser TypeName
parseTypeName = lexeme (TypeName <$> parseCapitalized)

parseQualTypeName :: Parser QualTypeName
parseQualTypeName =
    do md <- unModuleName <$> parseModuleName
       case reverse md of
         [] -> fail "This should never happen"
         (x:xs) ->
             return $ QualTypeName (ModuleName $ reverse xs) (TypeName x)

parseChoiceName :: Parser ChoiceName
parseChoiceName = lexeme (ChoiceName <$> parseCapitalized)

parseCapitalized :: Parser T.Text
parseCapitalized =
    do first <- satisfy isUpper
       rest <- many (alphaNum <|> char '_')
       return $ T.pack (first : rest)

languageDef :: P.GenLanguageDef T.Text st Identity
languageDef =
    P.LanguageDef
    { P.commentStart = "/*"
    , P.commentEnd = "*/"
    , P.commentLine = "//"
    , P.nestedComments = True
    , P.identStart = satisfy isLower
    , P.identLetter = alphaNum <|> oneOf "_"
    , P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
    , P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
    , P.reservedNames =
        [ "module", "type", "enum", "api", "import", "as" ]
    , P.reservedOpNames = [":", "->", "/", "="]
    , P.caseSensitive = False
    }

lexer :: P.GenTokenParser T.Text () Identity
lexer = P.makeTokenParser languageDef

stringLiteral :: Parser String
stringLiteral = P.stringLiteral lexer

parens :: Parser a -> Parser a
parens = P.parens lexer

braces :: Parser a -> Parser a
braces = P.braces lexer

brackets :: Parser a -> Parser a
brackets = P.brackets lexer

angles :: Parser a -> Parser a
angles = P.angles lexer

lexeme :: Parser a -> Parser a
lexeme = P.lexeme lexer

identifier :: Parser String
identifier = P.identifier lexer

reserved :: String -> Parser ()
reserved = P.reserved lexer

reservedOp :: String -> Parser ()
reservedOp = P.reservedOp lexer

semi :: Parser String
semi = P.semi lexer

dot :: Parser String
dot = P.dot lexer

dotSep1 :: Parser a -> Parser [a]
dotSep1 p = sepBy p dot

slashSep1 :: Parser a -> Parser [a]
slashSep1 p = sepBy p (reservedOp "/")

commaSep1 :: Parser a -> Parser [a]
commaSep1 = P.commaSep1 lexer