{-# LANGUAGE Arrows, ExistentialQuantification, GADTs, Rank2Types, FlexibleContexts, ScopedTypeVariables
    , EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, FunctionalDependencies, UndecidableInstances
    , TypeFamilies  #-}

module Language.Grammars.SyntaxMacros where

import Language.AbstractSyntax.TTTAS
import Control.Arrow

import UU.Parsing hiding (Symbol,parse,Ok)
import qualified UU.Parsing as UU
import Language.Grammars.SyntaxMacros.Scanner

import Language.Grammars.Grammar
import Language.Grammars.Transformations.LeftCorner
import Language.Grammars.Transformations.LeftFact

type GramTrafo = Trafo Unit Productions
type ExtGram      env      nts   
           = GramTrafo env  ()   (nts env)
type SyntaxMacro  env nts  nts'  
           = GramTrafo env  (nts env)  (nts' env)

data Export start nts env = Export (Symbol start env) (nts env)

-- add a new non-terminal to the grammar
addNT  ::  GramTrafo env [Prod a env] (Symbol a env)
addNT  =  proc  p -> do 
                r  <- newSRef -< PS p
                returnA -< Nont r


-- add productions to an existing non-terminal
addProds  ::  GramTrafo  env 
                          (Symbol a env, [Prod a env]) ()
addProds  = proc (Nont nt, prds) -> do
      updateFinalEnv  -< 
         updateEnv (\(PS ps) -> PS $ prds ++ ps) nt

-- close the grammar
closeGram :: (forall env. ExtGram  env (Export a nts)) 
                -> Grammar a 
closeGram prds  = case runTrafo prds Unit () of
     Result _ (Export (Nont r) _) gram 
            -> (leftfactoring . leftcorner) $ Grammar r gram


extendGram  ::  (NTRecord (nts env), NTRecord (nts' env))  
            =>  ExtGram env (Export start nts) 
                -> SyntaxMacro env (Export start nts) (Export start' nts') 
                -> ExtGram env (Export start' nts')
extendGram g sm = g >>> sm

exportNTs ::  NTRecord (nts env) => GramTrafo env (Export start nts env) (Export start nts env)
exportNTs = returnA


-- extensible record

newtype  NTField nt a env = NTField { symbolNTField :: (Symbol a env) }  

labelNTField :: NTField nt a env -> nt
labelNTField _ = undefined

data  NTCons nt v l env  = NTCons (NTField nt v env) (l env)
data  NTNil         env  = NTNil

class NTRecord r 
instance NTRecord (NTNil env)
instance (NTRecord (l env), NotDuplicated nt (l env)) => NTRecord (NTCons nt v l env)


class Fail err

data Duplicated nt

class NotDuplicated nt r
instance NotDuplicated nt (NTNil env)
instance Fail (Duplicated nt)      => NotDuplicated nt  (NTCons nt v l env) -- using overlapping
instance NotDuplicated nt1 (l env) => NotDuplicated nt1 (NTCons nt2 v l env)


ntNil = NTNil

infixr 4 ^= 
(^=) :: nt -> (Symbol a env) -> NTField nt a env
(^=) _ = NTField


infixr 2 ^| 
(^|) :: NTRecord (NTCons nt a l env) => NTField nt a env -> l env -> NTCons nt a l env
(^|) = NTCons


class GetNT nt r v | nt r -> v where
  getNT :: nt -> r -> v

data NotFound nt

instance Fail (NotFound nt) => GetNT nt (NTNil env) r where
 getNT = undefined
instance GetNT nt  (NTCons nt v l env) (Symbol v env) where -- using overlapping
 getNT _ (NTCons f _)  = symbolNTField f
instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where
 getNT nt (NTCons _ l)  = getNT nt l


-- COMPILE --------------------------------------------------------------------

pInt            ::   Parser Token Int
pChr            ::   Parser Token Char
pCon            ::   Parser Token String
pVar            ::   Parser Token String
pOp             ::   Parser Token String

pChr            =    head <$> pChar
pInt            =    read <$> pInteger
pCon            =    id <$> pConid
pVar            =    id <$> pVarid
pOp             =    id <$> pVarsym

pTerm t         =  const DTerm <$>   (pKey t)

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


compile :: Grammar a -> Parser Token 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 t env -> Parser Token t
         comp (End x)   = pLow x 
         comp (Seq (Term t) ss) 
                       = flip ($)  <$> pTerm t <*> comp ss 
         comp (Seq (Nont n) ss) 
                       = flip ($)  <$> unC (lookupEnv n result)
                                     <*> comp ss
         comp (Seq (NontInt) ss) 
                       = flip ($)  <$> pInt <*> comp ss 
         comp (Seq (NontChar) ss) 
                       = flip ($)  <$> pChr <*> comp ss 
         comp (Seq (NontVarid) ss) 
                       = flip ($)  <$> pVar <*> comp ss 
         comp (Seq (NontConid) ss) 
                       = flip ($)  <$> pCon <*> comp ss 
         comp (Seq (NontOp) ss) 
                       = flip ($)  <$> pOp  <*> comp ss 


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)


-- PARSE ----------------------------------------------------------------------

type ParseMsg = Message Token (Maybe Token)

data ParseResult a = Ok  a
                   | Rep a [ParseMsg] 
      deriving Show

parse :: Parser Token a -> [Token] -> ParseResult a
parse p input = case rparse p input of
                  (a,[]  ) -> Ok a
                  (a,msgs) -> Rep a msgs


rparse :: Parser Token a -> [Token] -> (a, [ParseMsg])
rparse p input = let ((Pair a _),msgs) =  eval (UU.parse p input)
                 in (a,msgs)
 where eval :: Steps a Token (Maybe Token) -> (a, [ParseMsg])
       eval (OkVal v        r) = let (a,msgs) = v `seq` eval r 
                                 in  (v a,msgs)
       eval (UU.Ok          r) = eval r
       eval (Cost  _        r) = eval  r
       eval (StRepair _ msg r) = let (v,msgs) = eval r 
                                 in  (v,msg:msgs)
       eval (Best _   r     _) = eval  r
       eval (NoMoreSteps v   ) = (v,[])