{-# LANGUAGE TypeOperators #-}

module ExprParserMultiRec where

import qualified ExprLexer as L
import Token
import Expr
import ParsecInstance ()
import MultiRecShow ()
import BoundsParser
import Annotations

import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as PP
import Control.Monad.Either ()
import Generics.MultiRec
import Generics.MultiRec.HFix

import Control.Applicative


type ExprWithBounds   = WithBounds  ExprFam Expr
type ExprWithBounds1  = WithBounds1 ExprFam Expr

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

type ExprFix = HFix (PF ExprFam ExprFam) Expr

unannotate :: HFunctor g => HFix ((f :*: g) s) ix -> HFix (g s) ix
unannotate = HIn . hmap (const unannotate) . snd' . hout

fst' :: (f :*: g) s r ix -> f s r ix
fst' (x :*: _) = x

snd' :: (f :*: g) s r ix -> g s r ix
snd' (_ :*: y) = y

mark :: (Symbol t, Show t, P.Stream str m t) =>
  P.ParsecT str u m (WithBounds1 s ix `Either` WithBounds s ix) ->
  P.ParsecT str u m (WithBounds s ix)
mark p = do
  lb <- getLeftBounds
  eith <- p
  case eith of
    Left ef -> do
      rb <- getRightBounds
      return (HIn (K (mkBounds lb rb) :*: ef))
    Right eaf ->
      return eaf

chainr1 :: ExprParser ExprWithBounds -> ExprParser (ExprWithBounds -> ExprWithBounds -> ExprWithBounds1) -> ExprParser ExprWithBounds
chainr1 pUnit pOp = loop where
  loop = mark $ do
    x <- pUnit
    mf <- P.optionMaybe (flip <$> pOp <*> loop)
    case mf of
      Just f -> return (Left (f x))
      Nothing -> return (Right x)

pTokenSatisfy :: (L.ExprToken -> Bool) -> ExprParser L.ExprToken
pTokenSatisfy pred = P.tokenPrim show 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 ExprWithBounds
pExpr = chainr1 pTerm ((\x y -> R (L (I x :*: I y))) <$ pToken L.Plus)

pTerm :: ExprParser ExprWithBounds
pTerm = chainr1 pFactor ((\x y -> R (R (I x :*: I y))) <$ pToken L.Star)

pFactor :: ExprParser ExprWithBounds
pFactor = pNum <|> pToken L.POpen *> pExpr <* pToken L.PClose

pNum :: ExprParser ExprWithBounds
pNum = mark $ (\(L.Num n) -> Left (L (K n))) <$> pTokenSatisfy L.isNum

parseExpr :: String -> Either P.ParseError ExprWithBounds
parseExpr input = P.runParser (L.pTokens <* P.eof) () "" input
                  >>= P.runParser (pExpr <* P.eof) () ""