module Fun.Parser where

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)

----

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

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

isDigit :: Char -> Bool
isDigit = (`elem` "0123456789")

isAlpha :: Char -> Bool
isAlpha = (`elem` lowerAlpha ++ upperAlpha)

isLower :: Char -> Bool
isLower = (`elem` lowerAlpha)

isUpper :: Char -> Bool
isUpper = (`elem` 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"

specialWord :: Parser String
specialWord = oneOrMore (alphanum <|> special) <?> "special word"

internalWord :: Parser String
internalWord = literal '_' <+> specialWord >>> build <?> "special word"
  where build (x, xs) = x : xs

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"

iterFull :: Parser a -> Parser [a]
iterFull m = m <+> iterFull m >>> (\(x, y) -> x : y) <|> iterFull'
iterFull' "" = Right ([], "")
iterFull' _  = Left $ State [] $ Nothing

acceptSpecial :: String -> Parser String
acceptSpecial w = specialWord <=> (== 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