module Fun.Grammar where

import           Fun.Parser
import           Fun.Tree
import           Fun.Typer

program :: Parser Program
program = iterFull block >>> Program <?> "program"

block :: Parser Block
block = functionBlock <+-> newline <|> functionBlock <+-> endOfFile <?> "block"

visibility :: Parser Visibility
visibility =
  (literal '+' >>> const PublicVisibility)
    <|> (literal '-' >>> const PrivateVisibility)
    <?> "visibility"

functionBlock :: Parser Block
functionBlock = functionDeclaration <+> iter functionDefinition >>> build
  where build (decl, defn) = FunctionBlock decl defn

functionDeclaration :: Parser FunctionDeclaration
functionDeclaration =
  functionDeclarationWithoutFlags
    <|> functionDeclarationWithFlags
    <?> "function declaration"

functionDeclarationWithoutFlags :: Parser FunctionDeclaration
functionDeclarationWithoutFlags =
  functionName
    <+>  functionDeclarationDelimiter
    <+>  functionTypes
    <+-> newline
    >>>  build
    <?>  "function declaration without flags"
  where build ((name, vis), types) = FunctionDeclaration name vis types []

functionDeclarationWithFlags :: Parser FunctionDeclaration
functionDeclarationWithFlags =
  functionName
    <+>  functionDeclarationDelimiter
    <+>  functionTypes
    <+-> space
    <+-> functionFlagDelimiter
    <+>  functionFlagList
    >>>  build
    <?>  "function declaration with flags"
 where
  build (((name, vis), types), flags) =
    FunctionDeclaration name vis types flags

functionDeclarationDelimiter :: Parser Visibility
functionDeclarationDelimiter =
  space
    <-+> literal ':'
    <-+> visibility
    <+-> literal ':'
    <+-> space
    <?>  "function declaration delimiter"

internalFunctions :: [String]
internalFunctions = ["_start", "_asm"]

functionName :: Parser String
functionName =
  letter
    <+>  iter (special <|> alphanum)
    >>>  build
    <|>  internalWord
    <=>  (`elem` internalFunctions)
    <|>  literal '('
    <-+> functionInfixName
    <+-> literal ')'
    <?>  "function name"
  where build (first, rest) = first : rest

functionInfixName :: Parser String
functionInfixName =
  (special <|> letter)
    <+> iter (special <|> alphanum)
    >>> build
    <|> internalWord
    <=> (`elem` internalFunctions)
    <?> "infix function name"
  where build (first, rest) = first : rest

functionTypes :: Parser [Type]
functionTypes =
  iter (functionType <+-> space <+-> functionTypeDelimiter <+-> space)
    <+> functionType
    >>> build
    <?> "function types"
  where build (a, b) = a ++ [b]

internalTypes :: [String]
internalTypes = ["_void"]

functionType :: Parser Type
functionType =
  (letter <=> isUpper)
    <+>  oneOrMore alphanum
    >>>  build
    <|>  internalWord
    <=>  (`elem` internalTypes)
    >>>  buildInternal
    <|>  literal '['
    <-+> functionType
    <+-> literal ']'
    >>>  buildList
    <?>  "function type"
 where
  build (first, rest) = resolveType $ first : rest
  buildInternal t = resolveType t
  buildList t = ListType t

functionTypeDelimiter :: Parser Char
functionTypeDelimiter = literal ':' <?> "function type delimiter"

functionFlagList :: Parser [FunctionFlag]
functionFlagList =
  (iter (space <-+> functionFlag)) <+-> newline >>> build <?> "function flags"
  where build list = map read list

functionFlagDelimiter :: Parser Char
functionFlagDelimiter = literal '%' <?> "function flag delimiter"

functionFlags :: [String]
functionFlags = ["inline", "deprecated", "danger-void", "danger-asm"]

functionFlag :: Parser String
functionFlag = specialWord <=> (`elem` functionFlags) <?> "function flag"

functionDefinition :: Parser FunctionDefinition
functionDefinition =
  (functionPattern <+-> literal ':')
    <+> functionBody
    >>> build
    <?> "function definition"
  where build (pattern, body) = FunctionDefinition pattern body

functionPattern :: Parser FunctionPattern
functionPattern =
  iter (functionPatternElement <+-> space)
    >>> FunctionPattern
    <?> "function pattern"

functionPatternElement :: Parser FunctionPatternElement
functionPatternElement =
  (functionParameter >>> FunctionPatternParameter)
    <|> (literal '_' >>> const FunctionPatternWildcard)
    <|> (number >>> FunctionPatternNumber)
    <|> (string >>> FunctionPatternString)
    <?> "function pattern element"

functionParameter :: Parser String
functionParameter =
  letters <|> (letter <+> oneOrMore alphanum) >>> build <?> "function parameter"
  where build (a, b) = a : b

functionArgument :: Parser FunctionArgument
functionArgument =
  (functionName >>> FunctionName)
    <|> (functionParameter >>> FunctionParameter)
    <|> (string >>> FunctionString)
    <|> (number >>> FunctionNumber)
    <?> "function argument"

functionBodyExpression :: Parser FunctionBody
functionBodyExpression =
  (functionName <+> iter (space <-+> functionArgument) >>> buildCall)
    <|> (    functionArgument -- TODO: Fixity precedence in parser? Hmmm
        <+-> space
        <+>  functionInfixName
        <+-> space
        <+>  functionArgument
        >>>  buildInfixCall
        )
    <|> (literal '(' <-+> functionBody <+-> literal ')' >>> FunctionBodySub)
 where
  buildCall (name, args) = FunctionBodyCall name args
  buildInfixCall ((arg1, name), arg2) = FunctionBodyInfixCall name [arg1, arg2]

functionBody :: Parser FunctionBody
functionBody =
  space
    <-+> (functionBodyExpression <|> functionArgument >>> FunctionBodyValue)
    <+-> newline