{-# LANGUAGE ExistentialQuantification, GADTs #-}

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        env  ->  Prod   (b -> a)  env  
                                        ->  Prod   a         env
      End   ::  a                       ->  Prod   a         env

data DTerm = DTerm

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

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

infixl 5  `ext`
ext :: Env Productions env def' -> [Prod a env]
    -> Env Productions env (def', a)
ext g = Ext g . PS 



matchSym  ::  Symbol a env -> Symbol b env 
          ->  Maybe (Equal a b)
matchSym (Nont x)   (Nont y)             = 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 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)


data Lit a env = Lit (a env)

int   ::  Lit (Symbol Int) env
char  ::  Lit (Symbol Char) env
var   ::  Lit (Symbol String) env
con   ::  Lit (Symbol String) env
op    ::  Lit (Symbol String) env

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

infixr 6 -:-
(-:-) = (,)

infixr 5 <.>, -.>, .>, <#>, -#>, #>

prd a = a ($)
prdId nt = Seq nt  $ End id

((chn,s)   <.>  ps)  f =  Seq s $ ps f'
        where f' sem r = \x -> f sem (chn .=. x .*. r) 

(pn,Lit s) -.> pp = \r ->  Seq s $ pp (f r)
               where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) 

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


((chn,s)   <#>  sem) f = Seq s (End $ f')
        where f' = \x -> f  sem 
                             (chn .=. x .*. emptyRecord)

(pn,Lit s) -#> ff = \r -> Seq s (End $ f r)
               where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord)

s  #> ff = \r ->  Seq (Term s) (End $ f r)
               where f r = \DTerm -> r ff emptyRecord 

{-
-- DOESN'T WORK

class ProdSeq a b c v v' | a -> b, b -> c  where
  (<.>) ::  (HExtend (LVPair t v) l l') =>
             (t, a env)-> 
             ((t1 -> l -> v' -> t2) -> Prod b env)-> 
             (t1 -> l' -> t2)-> 
             Prod c env

instance ProdSeq (Symbol b) (b->a) a v v where
  (pn,s) <.> pp = \r ->  Seq s $ pp (f r)
               where f r ff p = \x -> r ff (pn .=. x .*. p) 


instance ProdSeq (Lit (Symbol b)) (b->a) a (Record HNil -> v) v  where
  (pn,Lit s) <..> pp = \r ->  Seq s $ pp (f r)
               where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) 

-- WORKS

class ProdEnd a b | a -> b where
  (<#>) :: (t, a env) -> t1-> (t1 -> Record (HCons (LVPair t b) HNil) -> t2) -> Prod t2 env

instance ProdEnd (Symbol v) v where
  (pn,s) <#> ff = \r -> Seq s (End $ f r)
               where f r = \x -> r ff (pn .=. x .*. emptyRecord)

instance ProdEnd (Lit (Symbol v)) (Record HNil -> v) where
 (pn,Lit s) <#> ff = \r -> Seq s (End $ f r)
               where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord)
-}