module Language.Grammars.Murder.UUParsing where


import qualified Text.ParserCombinators.UU.Core as UU
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.Utils
import Text.ParserCombinators.UU.BasicInstances hiding (Parser,input,msgs)

import Language.Grammars.Grammar
import Language.AbstractSyntax.TTTAS


type Parser a = P (Str Char String LineCol) a

pInt :: Parser Int
pInt  = pInteger
pChr :: Parser Char
pChr  = pAscii

pVar :: Parser String
pVar  = ((:) <$> pLower <*> pList pIdChar `micro` 2) <* spaces 

pCon :: Parser String
pCon  = ((:) <$> pUpper <*> pList pIdChar `micro` 2) <* spaces

pIdChar :: Parser Char
pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"

pOp :: Parser String
pOp   = (pList1 $ pAnySym ('|':"!#$%&*+./<=>?@\\^-~:") `micro` 2) <* spaces

pTerm :: String -> Parser String
pTerm keyw = pToken keyw `micro` 1 <* spaces
spaces :: Parser String
spaces = pMunch (`elem` " \n")

lc2Pos :: LineCol -> Pos
lc2Pos (LineCol l c) = Pos l c

newtype Const f a s = C {unC :: f a}

-- | The function 'compile' generates a parser out of a closed grammar 
compile :: Grammar a -> Parser a
compile (Grammar (start :: Ref a env) rules) 
                       = unC (lookupEnv start result)
  where  result  =  
          mapEnv 
          (\ (PS ps) -> C (foldr1 (<|>) [ comp p | p <- ps]))
          rules

         comp :: forall t . Prod NF t env -> Parser t

         comp (Star     x y)   = comp x <*>   comp y
         comp (FlipStar x y)   = comp x <**>  comp y
         comp (Pure     x)     = pure x

         comp (Sym (Term t))   = (DTerm . lc2Pos) <$> pPos <*> pTerm t
         comp (Sym (Nont n))   = unC (lookupEnv n result)

         comp (Sym TermInt)    = (DTerm . lc2Pos) <$> pPos <*> pInt
         comp (Sym TermChar)   = (DTerm . lc2Pos) <$> pPos <*> pChr
         comp (Sym TermVarid)  = (DTerm . lc2Pos) <$> pPos <*> pVar
         comp (Sym TermConid)  = (DTerm . lc2Pos) <$> pPos <*> pCon
         comp (Sym TermOp)     = (DTerm . lc2Pos) <$> pPos <*> pOp


mapEnv  ::  (forall a . f a s -> g a s)  
        ->  Env f s env -> Env g s env
mapEnv  _ Empty       = Empty
mapEnv  f (Ext r v)   = Ext (mapEnv f r) (f v)



data ParseResult a = Ok  a
                   | Rep a [Error LineCol] 
      deriving Show

-- | The function 'parse' runs the parser for an input.
parse :: Parser a -> String -> ParseResult a
parse p input = case UU.parse ( (,) <$> p <*> pEnd) (createStr (LineCol 0 0) input) of
                  (a,[]  ) -> Ok a
                  (a,msgs) -> Rep a msgs