{-# LANGUAGE ExistentialQuantification, GADTs, EmptyDataDecls, 
    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances  #-}

module Language.Grammars.Grammar where

import Language.AbstractSyntax.TTTAS
import Language.Grammars.AspectAG hiding (append)


data Grammar a  
  = forall env . Grammar  (Ref a env)  
                          (Env Productions env env)

newtype Productions a env 
  = PS {unPS :: [Prod a env]}

data Prod a env where
      Seq   ::  Symbol    b  t     env  ->  Prod   (b -> a)  env  
                                        ->  Prod   a         env
      End   ::  a                       ->  Prod   a         env

data DTerm = DTerm

data TTerm
data TNonT
data TAttT

data Symbol a t env where
  Term    :: String    ->  Symbol  DTerm    TTerm   env

  Nont    :: Ref a env ->  Symbol  a        TNonT   env
  -- attributed terminals
  NontInt   ::             Symbol  Int      TAttT   env
  NontChar  ::             Symbol  Char     TAttT   env
  NontVarid ::             Symbol  String   TAttT   env
  NontConid ::             Symbol  String   TAttT   env
  NontOp    ::             Symbol  String   TAttT   env 
  --- TODO: the rest of EnumValToken

getRefNT :: Symbol a TNonT env -> Ref a env
getRefNT (Nont ref) = ref


pairEq :: Maybe (Equal a b) -> Maybe (Equal (a,t) (b,t))
pairEq (Just Eq) = Just Eq
pairEq Nothing   = Nothing

matchSym  ::  Symbol a t1 env -> Symbol b t2 env 
          ->  Maybe (Equal (a,t1) (b,t2))
matchSym (Nont x)   (Nont y)             = pairEq $ match x y
matchSym (Term x)   (Term y) | x == y    = Just Eq
matchSym NontInt    NontInt              = Just Eq
matchSym NontVarid  NontVarid            = Just Eq
matchSym NontConid  NontConid            = Just Eq
matchSym NontOp     NontOp               = Just Eq
matchSym _          _                    = Nothing


append  :: (a -> b -> c) -> Prod a env -> Symbol b t env 
        -> Prod c env
append g (End f     )  s  =  Seq s  (End (g f))
append g (Seq t ts  )  s  
  =  Seq t (append  (\b c d -> g (b d) c) ts s)


int   ::  Symbol Int     TAttT  env
char  ::  Symbol Char    TAttT  env
var   ::  Symbol String  TAttT  env
con   ::  Symbol String  TAttT  env
op    ::  Symbol String  TAttT  env

int   =  NontInt
char  =  NontChar
var   =  NontVarid
con   =  NontConid
op    =  NontOp


data EP a b env = EP a (b env)
infixr 6 <=>

(<=>) ::  a -> b env -> EP a b env
(<=>) = EP


infixr 5 <.>

data PreProd a b env = PreProd (a -> (Prod b env))

class ProdSeq a b c d | a c -> b d  where
  (<.>) :: a env -> b env -> PreProd c d env

instance (HExtend (LVPair t v) l l') => ProdSeq  
        (EP t (Symbol b TNonT))
        (PreProd (l -> v -> t2) (b -> a))
        (l' -> t2)
        a where

  (EP chn s)   <.>  (PreProd ps) = PreProd $ 
         \f ->  let f' r = \x -> f (chn .=. x .*. r) 
                in   Seq s $ ps f'

instance (HExtend (LVPair t (Record HNil -> v)) l l') => ProdSeq
        (EP t (Symbol b TAttT))
        (PreProd (l -> v -> t2) (b -> a))
        (l' -> t2)
        a where

   (EP pn s) <.> (PreProd pp) =  PreProd $ \r ->  Seq s $ pp (f r)
               where f r p = \x -> r (pn .=. (\(Record HNil) -> x) .*. p) 


instance ProdSeq
        (Symbol DTerm TTerm)
        (PreProd (t1 -> DTerm -> t2) (DTerm -> a))
        (t1 -> t2)
        a where

  s  <.> (PreProd pp) = PreProd $ \r -> Seq s $ pp (f r)
               where f r p = \DTerm -> r p 

prdEnd ::  PreProd (Record HNil -> b) b env
prdEnd = PreProd $ \f -> End (f emptyRecord)

prd ::  (a -> b) -> PreProd (a -> b) t t1 -> Prod t t1
prd sem (PreProd ps) = ps sem  

prdId ::  Symbol a TNonT env -> Prod a env
prdId nt = Seq nt  $ End id