ChristmasTree-0.2: examples/Test.hs

module Test where

import Text.GRead
import Language.AbstractSyntax.TTTAS

infixl 5 :<:, :+:
infixr 6 :>:, :*:

data T1  =  T1 :<: T1
         |  T1 :>: T1
         |  C1
         deriving (Read, Show)

data T2 a  =  T2 a  :+: T2 a
           |  a     :*: T2 a
           |  C2
         deriving (Read, Show)

data T3 = T3 T4 | C3
         deriving (Read, Show)
data T4 = T4 T3 | C4
         deriving (Read, Show)


_0 = Zero
_1 = Suc _0
_2 = Suc _1


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, 5) 
          ,  DPS  [  dNont (_T2,  6)  .#. dTerm ":+:" .#.
                     dNont (_T2,  6)  .#. dEnd infixP ] 
          )
       ,  (  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 

envT3T4 :: Env DGram (((), T4), T3) (((), T4), T3)
envT3T4 =  consD (nonts3 _0 _1) $
           consD (nonts4 _1 _0) Empty  
     where
      nonts3 _T3 _T4 = DLNontDefs
       [  (  DRef (_T3,10) 
          ,  DPS  [  dTerm "T3" .#. dNont (_T4,0) .#. 
                     dEnd consT3 
                  ,  dTerm "C3" .#. dEnd (const C3) 
                  ,  dTerm "(" .#. dNont (_T3,0) .#. 
                     dTerm ")" .#. dEnd parenT  
                  ]
          )
       ]
      nonts4 _T4 _T3 = DLNontDefs
       [  (  DRef (_T4,10) 
          ,  DPS  [  dTerm "T4" .#. dNont (_T3,0) .#. 
                     dEnd consT4 
                  ,  dTerm "C4" .#. dEnd (const C4) 
                  ,  dTerm "(" .#. dNont (_T4,0) .#. 
                     dTerm ")" .#. dEnd parenT  
                  ]
          )
       ]
      consT3 a  = const (T3 a) 
      consT4 a  = const (T4 a) 

instance Gram T3 where
 grammar = DGrammar _0 envT3T4

instance Gram T4 where
 grammar = DGrammar _1 envT3T4

read' :: (Gram a) => String -> a
read' input = case gread input of
                 Ok  a       -> a
                 Rep _ (m:_) -> error $ show m

v1 = read' "C1 :>: C1 :>: C1" :: T1
v2 = read' "C1 :<: C1 :<: C1" :: T1
v3 = read' "C1 :>: C1 :<: C1 :>: C1" :: T1
v4 = read' "(((((((((((((C1)))))))))))))" :: T1
v5 = read' "(C1 :>: C1) :*: C2 :+: C2" :: T2 T1
v6 = read' "T3 T4 T3 T4 C3" :: T3
v7 = read' "T4 T3 T4 T3 T4 C3" :: T4
v8 = read' "bla" :: T1 -- error