module Fun.Parser where

import           Data.Char
import           Fun.Tree

type Context = Maybe String
type Parser a = String -> Either Context (a, String)

char :: Parser Char
char []       = Left Nothing
char (x : xs) = Right (x, xs)

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

digits :: Parser String
digits = iter digit

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

space :: Parser Char
space = char <=> isSpace

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

notSpace :: Parser Char
notSpace = char <=> (not . isSpace)

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

letters :: Parser String
letters = iter letter

alphanum :: Parser Char
alphanum = digit <|> letter

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

literal :: Char -> Parser Char
literal c = char <=> (== c)

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

iter :: Parser Char -> Parser String
iter m = (iterS m) <=> (/= "")

iterS :: Parser a -> Parser [a]
iterS m = m <+> iterS m >>> (\(x, y) -> x : y) <|> result []

iterFail :: Parser a -> Parser [a]
iterFail m = m <+> iterFail m >>> (\(x, y) -> x : y)

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

-- A parser that will accept a given alpha string
acceptWord :: String -> Parser String
acceptWord w = token (letters <=> (== w))

-- A parser that will accept a given string
accept :: String -> Parser String
accept w = token ((iter 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 $ 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 _ -> parserB input
  result -> result

----

tree :: Parser Tree
tree = iterFail program >>> Tree

program :: Parser Program
program = iterFail block >>> Program

block :: Parser Block
block = functionBlock <+-> newline >>> Block

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

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

functionDeclaration :: Parser FunctionDeclaration
functionDeclaration =
  functionDeclarationWithoutFlags <|> functionDeclarationWithFlags

functionDeclarationWithoutFlags :: Parser FunctionDeclaration
functionDeclarationWithoutFlags =
  functionName
    <+>  functionDeclarationDelimiter
    <+>  functionTypeList
    <+-> newline
    >>>  build
  where build ((name, vis), types) = FunctionDeclaration name vis types []

functionDeclarationWithFlags :: Parser FunctionDeclaration
functionDeclarationWithFlags =
  functionName
    <+>  functionDeclarationDelimiter
    <+>  functionTypeList
    <+-> space
    <+-> literal '%'
    <+-> space
    <+>  functionFlagList
    <+-> newline
    >>>  build
 where
  build (((name, vis), types), flags) =
    FunctionDeclaration name vis types flags

functionDeclarationDelimiter :: Parser Visibility
functionDeclarationDelimiter =
  space <-+> literal ':' <-+> visibility <+-> literal ':' <+-> space

functionName :: Parser String -- TODO
functionName = letter <+> iterS alphanum >>> build where build (a, b) = a : b

functionTypeList :: Parser [String]
functionTypeList =
  (iterS (functionType <+-> space <+-> literal ':' <+-> space))
    <+> functionType
    >>> build
  where build (a, b) = a ++ [b]

functionType :: Parser String -- TODO
functionType = letter <+> iterS alphanum >>> build where build (a, b) = a : b

functionFlagList :: Parser [String]
functionFlagList = (iterS (functionFlag <+-> space)) <+> functionFlag >>> build
  where build (a, b) = a ++ [b]

functionFlags :: [String]
functionFlags = ["inline", "deprecated"]

functionFlag :: Parser String
functionFlag = letters <=> (`elem` functionFlags)

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

functionPattern :: Parser FunctionPattern
functionPattern = iterS (functionPatternElement <+-> space) >>> FunctionPattern

functionPatternElement :: Parser FunctionPatternElement
functionPatternElement =
  (functionParameter >>> FunctionPatternParameter)
    <|> (literal '_' >>> const Wildcard)
    <|> (number >>> FunctionPatternNumber)
    <|> (string >>> FunctionPatternString)

functionParameter :: Parser String -- TODO
functionParameter = letter <+> iterS alphanum >>> build
  where build (a, b) = a : b

functionBody :: Parser FunctionBody
functionBody =
  (iterS (functionBodyElement <+-> space))
    <+> (functionBodyElement <+-> newline)
    >>> build
    >>> FunctionBody
  where build (a, b) = a ++ [b]

functionBodyElement :: Parser FunctionBodyElement
functionBodyElement =
  statement
    <|> (functionName >>> FunctionBodyIdentifier)
    <|> (functionParameter >>> FunctionBodyIdentifier)
    <|> (string >>> FunctionBodyString)
    <|> (number >>> FunctionBodyNumber)

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