{-# LANGUAGE FlexibleContexts #-}

module ExprFParser (parsePosExpr, compileExpr) where

import ExprF
import Token
import qualified ExprLexer as L
import ParsecInstance ()
import BoundsParser
import Annotations

import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as PP
import qualified Text.Parsec.Error as PE
import Control.Applicative


type ExprTokens = [Token L.ExprToken]
type ExprParser = P.Parsec ExprTokens ()

pTokenSatisfy :: (Monad m, Symbol t) => (t -> Bool) -> P.ParsecT [Token t] u m t
pTokenSatisfy pred = P.tokenPrim (unparse . pure) incPos accept
  where
    incPos cur tok _ = PP.incSourceColumn cur (spaceBeforeSize tok + symbolSize tok)
    accept tok = if pred (tImage tok) then Just (tImage tok) else Nothing

pToken :: L.ExprToken -> ExprParser L.ExprToken
pToken = pTokenSatisfy . (==)

pExpr :: ExprParser (Ann Bounds ExprF)
pExpr = chainl pTerm (Add <$ pToken L.Plus <|> Sub <$ pToken L.Minus)

pTerm :: ExprParser (Ann Bounds ExprF)
pTerm = chainl pFactor (Mul <$ pToken L.Star <|> Div <$ pToken L.Slash)

pFactor :: ExprParser (Ann Bounds ExprF)
pFactor = pToken L.POpen *> pExpr <* pToken L.PClose <|> pNum

pNum :: ExprParser (Ann Bounds ExprF)
pNum = unit $ (\(L.Num n) -> Num n) <$> pTokenSatisfy L.isNum

parsePosExpr :: String -> Either P.ParseError (Ann Bounds ExprF)
parsePosExpr input = P.runParser (L.pTokens <* P.eof) () "" input
                     >>= P.runParser (pExpr <* P.eof) () ""

compileExpr :: (ErrorAlgebra ExprF e a) -> String -> Either String (Except [(e, Bounds)] a)
compileExpr f input =
  case parsePosExpr input of
    Left  err  -> Left  (showParseError err)
    Right expr -> Right (errorCata f expr)

-- mapLeft :: (a -> b) -> Either a c -> Either b c
-- mapLeft f e = case e of
--   Left x -> Left (f x)
--   Right x -> Right x

showParseError :: P.ParseError -> String
showParseError = tail . PE.showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages