update for outputting the AST representation of a PADS description

Language/Pads/CodeGen.hs

@@ -31,6 +31,7 @@ import qualified Data.Map as M
 import qualified Data.List as List
 import qualified Data.Maybe as Maybe
 import Control.Monad
+import Language.Haskell.TH.Syntax (lift)
 
 import Debug.Trace
 
@@ -51,43 +52,49 @@ make_pads_declarations' derivation ds = fmap concat (mapM (genPadsDecl derivatio
 
 genPadsDecl :: Derivation -> PadsDecl -> Q [Dec]
 
-genPadsDecl derivation (PadsDeclType name args pat padsTy) = do
+genPadsDecl derivation pd@(PadsDeclType name args pat padsTy) = do
   let typeDecs = mkTyRepMDDecl name args padsTy
   parseM  <- genPadsParseM name args pat padsTy
   parseS  <- genPadsParseS name args pat
   printFL <- genPadsPrintFL name args pat padsTy
   def <- genPadsDef name args pat padsTy
   let sigs = mkPadsSignature name args (fmap patType pat)
-  return $ typeDecs ++ parseM ++ parseS ++ printFL ++ def ++ sigs
+  ast <- astDecl name pd
+  return $ ast : typeDecs ++ parseM ++ parseS ++ printFL ++ def ++ sigs
 
-genPadsDecl derivation (PadsDeclData name args pat padsData derives) = do
+genPadsDecl derivation pd@(PadsDeclData name args pat padsData derives) = do
   dataDecs <- mkDataRepMDDecl derivation name args padsData derives
   parseM <- genPadsDataParseM name args pat padsData 
   parseS <- genPadsParseS name args pat
   printFL <- genPadsDataPrintFL name args pat padsData
   def <- genPadsDataDef name args pat padsData
   let instances = mkPadsInstance name args (fmap patType pat)
   let sigs = mkPadsSignature name args (fmap patType pat)
-  return $ dataDecs ++ parseM ++ parseS ++ printFL ++ def ++ instances ++ sigs
+  ast <- astDecl name pd
+  return $ ast : dataDecs ++ parseM ++ parseS ++ printFL ++ def ++ instances ++ sigs
 
-genPadsDecl derivation (PadsDeclNew name args pat branch derives) = do
+genPadsDecl derivation pd@(PadsDeclNew name args pat branch derives) = do
   dataDecs <- mkNewRepMDDecl derivation name args branch derives
   parseM <- genPadsNewParseM name args pat branch 
   parseS <- genPadsParseS name args pat
   printFL <- genPadsNewPrintFL name args pat branch
   def <- genPadsNewDef name args pat branch
   let instances = mkPadsInstance name args (fmap patType pat)
   let sigs = mkPadsSignature name args (fmap patType pat)
-  return $ dataDecs ++ parseM ++ parseS ++ printFL ++ def ++ instances ++ sigs
+  ast <- astDecl name pd
+  return $ ast : dataDecs ++ parseM ++ parseS ++ printFL ++ def ++ instances ++ sigs
 
-genPadsDecl derivation (PadsDeclObtain name args padsTy exp) = do
+genPadsDecl derivation pd@(PadsDeclObtain name args padsTy exp) = do
   let mdDec = mkObtainMDDecl name args padsTy
   parseM  <- genPadsObtainParseM name args padsTy exp
   parseS  <- genPadsParseS name args Nothing
   printFL <- genPadsObtainPrintFL name args padsTy exp
   def <- genPadsObtainDef name args padsTy exp
   let sigs = mkPadsSignature name args Nothing
-  return $ mdDec ++ parseM ++ parseS ++ printFL ++ def ++ sigs
+  ast <- astDecl name pd
+  return $ ast : mdDec ++ parseM ++ parseS ++ printFL ++ def ++ sigs
+
+astDecl name pd = funD (mkName $ "ast_" ++ name) [clause [] (normalB $ lift pd) []]
 
 patType :: Pat -> Type
 patType p = case p of

Language/Pads/GenPretty.hs

@@ -113,7 +113,7 @@ mkPrettyInstance' worklist done decls =
          let inst = AppT (ConT ''Pretty) (ConT ty_name)   
          let genericPprName = mkName "ppr"
          let ppr_method = ValD (VarP genericPprName) (NormalB (VarE specificPprName)) []
-         let instD = InstanceD [] inst [ppr_method]
+         let instD = InstanceD Nothing [] inst [ppr_method]
          let newDone = S.insert ty_name done
          info <- reify ty_name
          (nestedTyNames, decls') <- case info of 

Language/Pads/Padsc.hs

@@ -24,6 +24,7 @@ module Language.Pads.Padsc (
      module Language.Pads.Generic,
      module Language.Pads.CoreBaseTypes,
      module Language.Pads.Quote,
+     module Language.Pads.Syntax,
      module Language.Pads.BaseTypes,
      module Language.Pads.Pretty,
      module Language.Pads.PadsPrinter,
@@ -41,6 +42,7 @@ import Language.Pads.MetaData
 import Language.Pads.Generic
 import Language.Pads.CoreBaseTypes
 import Language.Pads.Quote
+import Language.Pads.Syntax
 import Language.Pads.BaseTypes
 import Language.Pads.Pretty
 import Language.Pads.PadsPrinter

Language/Pads/Syntax.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable,DeriveLift, DeriveAnyClass, DeriveGeneric #-}
 
 {-
 ** *********************************************************************
@@ -13,14 +13,19 @@
 
 module Language.Pads.Syntax where
 
-import Data.Generics
+import Data.Generics (Data(..), Typeable(..))
 import Language.Haskell.TH
+import Language.Haskell.TH.Lift (Lift(..))
+import GHC.Generics (Generic(..))
+
+instance Lift Pat
+instance Lift Exp
 
 data PadsDecl = PadsDeclType   String [String] (Maybe Pat) PadsTy
               | PadsDeclData   String [String] (Maybe Pat) PadsData [QString]
               | PadsDeclNew    String [String] (Maybe Pat) BranchInfo [QString]
               | PadsDeclObtain String [String] PadsTy Exp
-   deriving (Eq, Data, Typeable, Show)
+   deriving (Eq, Data, Typeable, Show, Lift, Generic)
 
 
 data PadsTy = PConstrain Pat PadsTy Exp
@@ -33,25 +38,25 @@ data PadsTy = PConstrain Pat PadsTy Exp
             | PExpression Exp
             | PTycon QString
             | PTyvar String
-   deriving (Eq, Data, Typeable, Show)
+   deriving (Eq, Data, Typeable, Show, Lift, Generic)
 
 data TermCond = LTerm PadsTy | LLen Exp
-  deriving (Eq, Data, Typeable, Show)
+  deriving (Eq, Data, Typeable, Show, Lift, Generic)
 
 
 data PadsData = PUnion [BranchInfo]
               | PSwitch Exp [(Pat,BranchInfo)]
-  deriving (Eq, Data, Typeable, Show)
+  deriving (Eq, Data, Typeable, Show, Lift, Generic)
 
 data BranchInfo = BRecord String [FieldInfo] (Maybe Exp)
                 | BConstr String [ConstrArg] (Maybe Exp)
-  deriving (Eq, Data, Typeable, Show)
+  deriving (Eq, Data, Typeable, Show, Lift, Generic)
 
 type FieldInfo = (Maybe String, ConstrArg, Maybe Exp)
 type ConstrArg = (PadsStrict, PadsTy)
 
 data PadsStrict = IsStrict | NotStrict | Unpacked
-  deriving (Eq, Data, Typeable, Show)
+  deriving (Eq, Data, Typeable, Show, Lift, Generic)
 
 type QString = [String]  -- qualified names
 

pads-haskell.cabal

@@ -102,7 +102,8 @@ Library
                     HUnit >= 1.2.5.2,
                     byteorder >= 1.0.4,
                     old-locale >= 1.0.0.6,
-                    time >= 1.4.2
+                    time >= 1.4.2,
+                    th-lift, transformers
 
   -- Modules not exported by this package.
 
@@ -124,6 +125,7 @@ Test-Suite examples
                 , test-framework-hunit
                 , test-framework-quickcheck2
                 , directory, byteorder
+                , th-lift, transformers
   default-language: Haskell2010
   other-modules:  Examples.Proc, Examples.First, Examples.AI, Examples.Binary
                 , Language.Pads.Testing