module Fun.Parser where

import           Fun.Tree

data Trace = StringTrace String | OrTrace [Trace] [Trace]
  deriving (Eq, Show)
data State = State
  { trace :: [Trace]
  , line  :: Maybe String
  }
  deriving (Eq, Show)
type Parser a = String -> Either State (a, String)

----
-- I don't use Data.Char because of planned future reimplementation in Fun
----

lowerAlpha :: [Char]
lowerAlpha = "abcdefghijklmnopqrstuvwxyzαβγδεζηθικλμνξοπρστυφχψω"

upperAlpha :: [Char]
upperAlpha = "ABCDEFGHIJKLMNOPQRSTUVWXYZΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ"

isDigit :: Char -> Bool
isDigit c = elem c "0123456789"

isAlpha :: Char -> Bool
isAlpha c = elem c $ lowerAlpha ++ upperAlpha

isLower :: Char -> Bool
isLower c = elem c lowerAlpha

isUpper :: Char -> Bool
isUpper c = elem c upperAlpha

----

char :: Parser Char
char []       = Left $ State [StringTrace "char"] Nothing
char (x : xs) = Right (x, xs)

endOfFile :: Parser Char
endOfFile [] = Right ('\00', [])
endOfFile _  = Left $ State [StringTrace "end of file"] Nothing

digit :: Parser Char
digit = char <=> isDigit <?> "digit"

digits :: Parser String
digits = oneOrMore digit <?> "digits"

number :: Parser Integer
number =
  literal '-'
    <-+> digits
    >>>  (\n -> -1 * (read n :: Integer))
    <|>  digits
    >>>  (\n -> read n :: Integer)
    <?>  "number"

space :: Parser Char
space = char <=> (== ' ') <?> "space"

notSpace :: Parser Char
notSpace = char <=> (/= ' ') <?> "non-space"

newline :: Parser Char
newline = char <=> (== '\n') <?> "newline"

letter :: Parser Char
letter = char <=> isAlpha <?> "letter"

letters :: Parser String
letters = oneOrMore letter <?> "letters"

alphanum :: Parser Char
alphanum = digit <|> letter <?> "letter or digit"

special :: Parser Char
special = oneOf "+-*/<^>$@#&!?" <?> "special character"

oneOf :: [Char] -> Parser Char
oneOf s = char <=> (`elem` s) <?> "one of"

string :: Parser String
string =
  literal '"' <-+> iter (char <=> (/= '"')) <+-> literal '"' <?> "string"

literal :: Char -> Parser Char
literal c = char <=> (== c) <?> "char (" ++ [c] ++ ")"

result :: a -> Parser a
result a cs = Right (a, cs)

oneOrMore :: Parser Char -> Parser String
oneOrMore m = (iter m) <=> (/= "") <?> "one or more chars"

iter :: Parser a -> Parser [a]
iter m = m <+> iter m >>> (\(x, y) -> x : y) <|> result [] <?> "multiple"

-- TODO: Improve this for better error reporting
iterFull :: Parser a -> Parser [a]
iterFull m = m <+> iterFull m >>> (\(x, y) -> x : y) <|> iterFull'
iterFull' "" = Right ([], "")
iterFull' _  = Left $ State [StringTrace "<something>"] $ Nothing

token :: Parser a -> Parser a
token = (<+-> space)

accept :: String -> Parser String
accept w = token ((oneOrMore notSpace) <=> (== w))

-- Given a parser and a predicate return the parser only if it satisfies the predicate
infix 7 <=>
(<=>) :: Parser a -> (a -> Bool) -> Parser a
(parser <=> predicate) input = case parser input of
  Left  a         -> Left a
  Right (a, rest) -> if (predicate a)
    then Right (a, rest)
    else Left $ State [] $ Just $ head . lines $ input

-- Combine two parser together pairing their results up in a tuple
infixl 6 <+>
(<+>) :: Parser a -> Parser b -> Parser (a, b)
(parserA <+> parserB) input = case parserA input of
  Left  a                    -> Left a
  Right (resultA, remainder) -> case parserB remainder of
    Left  a             -> Left a
    Right (resultB, cs) -> Right ((resultA, resultB), cs)

-- Sequence operator that discards the second result
infixl 6 <+->
(<+->) :: Parser a -> Parser b -> Parser a
(parserA <+-> parserB) input = case parserA input of
  Left  a                    -> Left a
  Right (resultA, remainder) -> case parserB remainder of
    Left  a       -> Left a
    Right (_, cs) -> Right (resultA, cs)

-- Sequence operator that discards the first result
infixl 6 <-+>
(<-+>) :: Parser a -> Parser b -> Parser b
(parserA <-+> parserB) input = case parserA input of
  Left  a                    -> Left a
  Right (resultA, remainder) -> case parserB remainder of
    Left  a             -> Left a
    Right (resultB, cs) -> Right (resultB, cs)

-- Transform a parsers result
infixl 5 >>>
(>>>) :: Parser a -> (a -> b) -> Parser b
(parser >>> transformer) input = case parser input of
  Left  a                    -> Left a
  Right (resultA, remainder) -> Right ((transformer resultA), remainder)

-- Extract a parsers result	
infix 4 +>
(+>) :: Parser a -> (a -> Parser b) -> Parser b
(parser +> function) input = case parser input of
  Left  a       -> Left a
  Right (a, cs) -> function a cs

-- Combine two parsers using a 'or' type operation
infixl 3 <|>
(<|>) :: Parser a -> Parser a -> Parser a
(parserA <|> parserB) input = case parserA input of
  Left (State t _) -> case parserB input of
    Left (State t' l) -> case (t, t') of
      (t , []) -> Left (State t l)
      ([], t') -> Left (State t' l)
      (t , t') -> Left (State [OrTrace t t'] l)
    Right (result, cs) -> Right (result, cs)
  result -> result

-- Describe a parser with a string for error reporting
infix 0 <?>
(<?>) :: Parser a -> String -> Parser a
(parser <?> string) input = case parser input of
  Left  (State t l) -> Left $ State ([StringTrace string] ++ t) l
  Right a           -> Right a

----

tree :: Parser Tree
tree = iterFull program >>> Tree

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

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

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

functionBlock :: Parser FunctionBlock
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"

functionName :: Parser String
functionName =
  (special <|> letter)
    <+> iter (special <|> alphanum)
    >>> build
    <?> "function name"
  where build (first, rest) = first : rest

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

functionType :: Parser String
functionType =
  (letter <=> isUpper) <+> oneOrMore alphanum >>> build <?> "function type"
  where build (first, rest) = first : rest

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"]

functionFlag :: Parser String
functionFlag = letters <=> (`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

functionBody :: Parser FunctionBody
functionBody =
  iter (space <-+> functionBodyElement)
    <+-> newline
    >>>  FunctionBody
    <?>  "function body"

functionBodyElement :: Parser FunctionBodyElement
functionBodyElement =
  statement
    <|> (functionName >>> FunctionBodyIdentifier)
    <|> (functionParameter >>> FunctionBodyIdentifier)
    <|> (string >>> FunctionBodyString)
    <|> (number >>> FunctionBodyNumber)
    <?> "function body element"

statement :: Parser FunctionBodyElement --  TODO
statement = accept "if" >>> Statement