Grammar.hs

{-# LANGUAGE ExistentialQuantification,
             RankNTypes #-}
{- | 

    Representation of Data Type Grammars.

-}
module Text.GRead.Grammar (
                       -- * Class Gram
                       Gram(..),
 
                       -- * Typed Grammar Representations for Data Types

                       -- ** Types
                       DGrammar(..), DGram(..), DRef(..), DLNontDefs(..),
                       DProductions(..), DProd(..), DSymbol(..), 
 
                       -- ** Smart Constructors
                       ( .#. ), consG, consD, dNont, dTerm, dEnd, parenT,

                       -- * Typed Grammar Representations

                       -- ** Types
                       Grammar(..), Productions(..), Prod(..), 
                       Symbol(..), Token(..),

                       -- ** Smart Constructors
                       ext, ( .*. ),

                       -- ** Utils
                       matchSym, append
                     ) where

import Language.AbstractSyntax.TTTAS (Env(..), Ref(..), Equal(..), match)

-- |
--
-- Class of data types with typed grammar representation. It has to be
-- instantiated in order to use the function 'Text.GRead.gread'.  
--
-- Instances can be derived automatically using the functions defined
-- in the module "Text.GRead.Derive".
-- 
-- For example, given the declarations
--
-- > infixl 5 :<:
-- > infixr 6 :>:, :*:
-- > 
-- > data T1  =  T1 :<: T1
-- >          |  T1 :>: T1
-- >          |  C1
-- > 
-- > data T2 a  =  a :*: T2 a
-- >            |  C2
--
-- the instances of 'Gram' can be
--
-- > _0 = Zero
-- > _1 = Suc _0
-- > 
-- > instance Gram T1 where
-- >  grammar = DGrammar   _0 envT1
-- > 
-- > envT1 :: Env DGram ((),T1) ((),T1) 
-- > envT1 =  consD (nonts _0) Empty 
-- >      where
-- >       nonts _T1 = DLNontDefs
-- >        [  (  DRef (_T1, 5) 
-- >           ,  DPS  [  dNont (_T1, 5) .#. dTerm ":<:" .#.
-- >                      dNont (_T1, 6) .#. dEnd infixL ]
-- >           )
-- >        ,  (  DRef (_T1, 6) 
-- >           ,  DPS  [  dNont (_T1, 7) .#. dTerm ":>:" .#.
-- >                      dNont (_T1, 6) .#. dEnd infixR ] 
-- >           ) 
-- >        ,  (  DRef (_T1,10) 
-- >           ,  DPS  [  dTerm "C1"   .#. dEnd (const C1)
-- >                   ,  dTerm "(" .#. dNont (_T1,0) .#. 
-- >                      dTerm ")" .#. dEnd parenT ] 
-- >           )
-- >        ]
-- >       infixL e1 _ e2   = e2 :<: e1
-- >       infixR e1 _ e2   = e2 :>: e1 
-- > 
-- > instance Gram a => Gram (T2 a) where
-- >  grammar = DGrammar   _0  envT2 
-- > 
-- > envT2 :: (Gram a) => Env DGram  (((),a),T2 a)
-- >                                 (((),a),T2 a)
-- > envT2 =  consD (nonts  _0 _1) $ 
-- >          consG grammar Empty
-- >      where
-- >       nonts _T2 _A = DLNontDefs
-- >        [  (  DRef (_T2, 6)
-- >           ,  DPS  [  dNont (_A,   7)  .#. dTerm ":*:" .#. 
-- >                      dNont (_T2,  7)  .#. dEnd infixT ] 
-- >           )
-- >        ,  (  DRef (_T2,10) 
-- >           ,  DPS  [  dTerm "C2"   .#. dEnd (const C2)
-- >                   ,  dTerm "("    .#. dNont (_T2,0) .#. 
-- >                      dTerm ")"    .#. dEnd parenT ] 
-- >           )
-- >        ]
-- >       infixP   e1 _ e2  = e2 :+: e1
-- >       infixT   e1 _ e2  = e2 :*: e1 
--
-- In case of mutually recursive datatypes, their definitions have
-- to be tupled together into a single environment.

class Gram a where
 -- | The function 'grammar' returns the grammar representation of
 --   the data type.
 grammar :: DGrammar a

-- | Data type describing grammatical structures of data types,
--   including information about precedences. The type @DGrammar a@
--   describes the grammar of the data type @a@.
data DGrammar a 
        -- | A grammar consists of an environment ('Env') with the
        --   defined non-terminals and a reference ('Ref') to the
        --   /main non-terminal/ in the environment.
        = forall env. DGrammar  (Ref a env) 
                                (Env DGram env env)
 
data DGram a env  =  DGD (DLNontDefs a env) 
                  |  DGG (DGrammar a)
newtype DRef a env = DRef (Ref a env, Int)
newtype DLNontDefs a env 
            = DLNontDefs [(DRef a env, DProductions a env)]
newtype DProductions a env 
            = DPS { unDPS :: [DProd a env] }
 
data DProd a env where
  DSeq    :: DSymbol b env  -> DProd (b->a) env 
                            -> DProd a env
  DEnd    :: a              -> DProd a env
 
data DSymbol a env where
  DNont  :: DRef a env  -> DSymbol a env
  DTerm  :: Token       -> DSymbol Token env

infixr 5 .#.

( .#. ) ::  DSymbol b env -> DProd (b -> a) env -> DProd a env
( .#. )                  = DSeq

consG :: DGrammar a -> Env DGram use def' -> Env DGram use (def', a)
consG   g es             = Ext    es (DGG g)

consD :: DLNontDefs a env -> Env DGram env def' -> Env DGram env (def', a)
consD   g es             = Ext    es (DGD g)

dNont ::  (Ref a env, Int) -> DSymbol a env
dNont   nt               = DNont  (DRef nt)

dTerm ::  [Char] -> DSymbol Token env
dTerm   t  | t == "("    = DTerm  Open
           | t == ")"    = DTerm  Close
           | otherwise   = DTerm  (Keyw t)

dEnd ::  a -> DProd a env
dEnd    f                = DEnd   f

parenT ::  t -> t1 -> t2 -> t1
parenT  _ e _            = e



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 Symbol a env where
  Nont :: Ref a env ->  Symbol  a       env
  Term :: Token     ->  Symbol  Token   env

data Token = Keyw String
           | Open
           | Close
         deriving (Ord, Eq)


infixr 5 `ext` , .*.

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

( .*. ) ::  Symbol b env -> Prod (b -> a) env -> Prod a env
( .*. )      = Seq

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 _         _                    = 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)