fregel-1.2.0: compiler/Spec.lhs

> {-# LANGUAGE FlexibleContexts,FlexibleInstances,MultiParamTypeClasses,FunctionalDependencies #-}

> module Spec where
> import Control.Monad.State
> import Data.List


BNF of the DSL (ver 1.0p2)


position of let-bindings is limited.

Program specification is I/O type definitions and a program body

  ProgramSpec := RecordSpec* Prog
  RecordSpec := 'data' Constructor '=' Constructor '{' Field '::' Type (',' Field '::' Type )* '}' 'deriving' '(' 'Eq' ',' 'Show' ')'
   -- simple version Constructor '{' Field '::' Type (',' Field '::' Type )* '}'
   -- not runnable in Haskell, though

> data DProgramSpec a = DProgramSpec [DRecordSpec a] (DProg a) a deriving (Show, Eq)
> data DRecordSpec a = DRecordSpec (DConstructor a) [(DField a, DType a)] a deriving (Show, Eq)

  
A program body is a graph function with ground definitions.
The argument is 'g'!  (this will be used in all global aggregations)

  Prog := Fun 'g' '=' 'let' GroundDefs 'in' GraphExpr
  GroundDefs := GroundDef (';' GraphDef)*    -- not indentation-based

> data DProg a = DProg (DFun a) [DGroundDef a] (DGraphExpr a) a deriving (Show, Eq)

A ground definition can contain definitions of vertex-compute functions.
A vertex-compute function receives two special tables Prev and Curr.

  GroundDef := DefVertComp | DefVertInit | DefGraphFun | DefGraphVar | SmplDef 
  DefVertComp := Fun 'v' 'prev' 'curr' '=' (Expr | 'let' SmplDefs 'in' Expr) 
  DefVertInit := Fun 'v' '=' (Expr | 'let' SmplDefs 'in' Expr) 
  DefGraphVar := Var '=' GraphExpr
  DefGraphFun := Fun Var '=' (GraphExpr | 'let' DefGraphVars 'in' GraphExpr)

> data DGroundDef a = DGDefVC (DDefVertComp a) a
>                   | DGDefVI (DDefVertInit a) a
>                   | DGDefGV (DDefGraphVar a) a
>                   | DGDefGF (DDefGraphFun a) a
>                   | DGDefSmpl (DSmplDef a) a 
>                    deriving (Show, Eq)
> data DDefVertComp a = DDefVertComp (DFun a) [DSmplDef a] (DExpr a) a deriving (Show, Eq)
> data DDefVertInit a = DDefVertInit (DFun a) [DSmplDef a] (DExpr a) a deriving (Show, Eq)
> data DDefGraphVar a = DDefGraphVar (DVar a) (DGraphExpr a) a deriving (Show, Eq)
> data DDefGraphFun a = DDefGraphFun (DFun a) (DVar a) [DDefGraphVar a] (DGraphExpr a) a deriving (Show, Eq)

A graph expression is made by 'pregel', 'gmap', 'gzip', 'giter', ... and restricted 'let' expressions.
-- pregel can be invoked on a variable and not on an expression

  GraphExpr := 'fregel' Fun Fun Termination Var
             | 'gmap' Fun Var
             | 'gzip' Var Var
             | 'giter' Fun Fun Termination Var
             | Var
  Termination := 'Fix'
               | '(' 'Iter' Expr ')'
               | '(' 'UntilAny' PredVExpr ')'
               | '(' 'UntilAll' PredVExpr ')'
               | '(' 'Until' PredExpr ')'
               | '(' 'While' PredExpr ')'
               | '(' Termination ')'

  UltilAny, UntilAll, While are replaced with Until + aux.
  
  PredExpr := '(' '\' 'g' '->' Expr ')'  # "\g->" is necessary to be run on Haskell
  PredVExpr := '(' '\' 'v' '->' Expr ')' # "\v->" is necessary to be run on Haskell
  DefGraphVars := DefGraphVar (';' DefGraphVar)*     -- not indentation-based

> data DGraphExpr a = DPregel (DFun a) (DFun a) (DTermination a) (DGraphExpr a) a -- (DVar a) a
>                   | DGMap (DFun a) (DGraphExpr a) a  -- (DVar a) a
>                   | DGZip (DGraphExpr a) (DGraphExpr a) a --(DVar a) (DVar a) a
>                   | DGIter (DFun a) (DFun a) (DTermination a) (DGraphExpr a) a -- (DVar a) a
>                   | DGVar (DVar a) a
>                    deriving (Show, Eq)
> data DTermination a = DTermF a
>                     | DTermI (DExpr a) a
>                     | DTermU (DExpr a) a
>                     | DTermV2H a           -- for internal use
>                      deriving (Show, Eq)

Definition of simple functions and variables (+ tuple binding).
(Is it necessary to distiguish these two?)

  SmplDef := DefFun | DefVar | DefTuple
  DefFun := Fun Var+ '=' (Expr | 'let' SmplDefs 'in' Expr)
  DefVar := Var '=' (Expr | 'let' SmplDefs 'in' Expr)
  DefTuple := '(' Var (',' Var)+ ')' '=' (Expr | 'let' SmplDefs 'in' Expr)
  SmplDefs := SmplDef (';' SmplDef)*             -- not indentation-based

> data DSmplDef a = DDefFun (DFun a) [DVar a] [DSmplDef a] (DExpr a) a
>                 | DDefVar (DVar a) [DSmplDef a] (DExpr a) a
>                 | DDefTuple [DVar a] [DSmplDef a] (DExpr a) a
>                  deriving (Show, Eq)

Expressions.
No anonimous function.
No let-expression ("let" is only allowed in the head of a function definition).

  Expr := If | Tuple | FunAp | Var | Const | FieldAccess | Aggr
        | '(' Expr ')'   -- this is for concrete syntax

  If := 'if' Expr 'then' Expr 'else' Expr
  Tuple := '(' Expr (',' Expr)+ ')'
  FunAp := Fun Expr+
         | Constructor Expr+
         | Expr '`' Fun '`' Expr
         | Expr BinOp Expr

  FieldAccess := (TableExpr | Edge ) (('.^' ('_fst' | '_snd'))* '.^' Field)?
  TableExpr := 'curr' Var | 'prev' Var | 'val' Var

Aggr := Agg '[' Expr '|' Gen (',' Expr )* ']'
      | Agg Expr '[' Expr '|' Gen (',' Expr )* ']'

  Edge := 'e'

  Gen := '(' 'e' ',' 'u' ')' '<-' 'is' 'v'
       | '(' 'e' ',' 'u' ')' '<-' 'rs' 'v'
       | 'u' '<-' 'g'   

> data DExpr a = DIf (DExpr a) (DExpr a) (DExpr a) a
>              | DTuple [DExpr a] a
>              | DFunAp (DFun a) [DExpr a] a
>              | DConsAp (DConstructor a) [DExpr a] a
>              | DFieldAcc (DTableExpr a) [DField a] a
>              | DFieldAccE (DEdge a) [DField a] a
>              | DAggr (DAgg a) (DExpr a) (DGen a) [DExpr a] a
>              | DCheckTerm (DExpr a) a -- Iwasaki: condition for termination
>              | DVExp (DVar a) a
>              | DCExp (DConst a) a
>              deriving (Show, Eq)
> data DGen a = DGenI a
>             | DGenO a
>             | DGenG a
>             | DGenTermG a  -- Iwasaki; aggregation for judging termination
>             deriving (Show, Eq)
> data DEdge a = DEdge a deriving (Show, Eq)
> data DTableExpr a = DPrev (DVar a) a
>                   | DCurr (DVar a) a
>                   | DVal (DVar a) a
>                   deriving (Show, Eq)

The identities must start with small letters or the underscore.
Prime symbols are allowed only at the end.

  BinOP := '+' | '-' | '*' | '/'
         | '==' | '!=' | '<' | '>' | '>=' | '<=' 
         | '&&' | '||'
  Agg := 'minimum' | 'maximum' | 'sum' | 'prod' | 'and' | 'or' | 'choice'
  Fun := [a-z_][a-zA-Z_0-9]*[']*
  Var := [a-z_][a-zA-Z_0-9]*[']*
  Field := [a-z_][a-zA-Z_0-9]*[']*
  Constructor := [A-Z][a-zA-Z_0-9]*[']*

> data DAgg a = DAggMin a
>             | DAggMax a
>             | DAggSum a
>             | DAggProd a
>             | DAggAnd a
>             | DAggOr a
>             | DAggChoice (DExpr a) a  -- random choice with default value
>             | DTupledAgg [DAgg a] a   -- for internal use
>               deriving (Show, Eq)
> data DConstructor a = DConstructor String a deriving (Show, Eq)
> data DFun a = DFun String a 
>             | DBinOp String a 
>               deriving (Show, Eq)
> data DVar a = DVar String a deriving (Show, Eq)
> data DField a = {- DFfst a | DFsnd a | -} DField String a deriving (Show, Eq)

Constants (integer, boolean, string, floating point number, ...)

 Const := Integer | Boolean | String | Double 

 Integer := '-'? ( [1-9][0-9]* | '0' )
 Boolean := 'True' | 'False'
 String  := '"' [^"]* '"'                  -- simple definition
 Double  := '-'? ( [1-9][0-9]* | '0' ) '.' [0-9]* 

> data DConst a = DCInt Int a 
>               | DCBool Bool a 
>               | DCString String a
>               | DCDouble Double a
>                 deriving (Show, Eq)

Types of each component in the I/O records.

 Type := 'Int' | 'Bool' | 'String' | 'Double' | '(' Type (',' Type)* ')'

> data DType a = DTInt a
>             | DTBool a
>             | DTString a
>             | DTDouble a
>             | DTTuple [DType a] a
>             | DTRecord (DConstructor a) [DType a] a  -- for internal use
>               deriving (Show, Eq)

------------------------- pretty printer? ------------------

> ppList :: String -> [String] -> String
> ppList c ss = foldr (\(s, c) r -> c ++ s ++ r) "" $ zip ss ("":repeat c)

> ppProgramSpec :: DProgramSpec a -> [String]
> ppProgramSpec (DProgramSpec rs p _) =
>   (concatMap ppRecordSpec rs) ++ ppProg p

> ppRecordSpec :: DRecordSpec a -> [String]
> ppRecordSpec (DRecordSpec c fts _) =
>   ["data " ++ ppConstructor c ++ " = " ++ ppConstructor c ++ "{" ++ ppfts ++ "} deriving (Eq, Show)"]
>   where ppfts = ppList ", " (map (\(f, t) -> ppField f++"::"++ppType t) fts)

> indentWith :: String -> [String] -> [String]
> indentWith s (l:ls) = (s++l) :map ((map (const ' ') s)++) ls
> indentWith s ([]) = []

> indent :: [String] -> [String]
> indent ls = indentWith "  " ls

> ppProg :: DProg a -> [String]
> ppProg (DProg f ds e _) = [ppFun f ++ " g = "] ++ rest
>   where rest = if length ds == 0 then indent (ppGraphExpr e)
>                else indent $ let_in (concat $ insList ";" "" $ map ppGroundDef ds) (ppGraphExpr e)

> let_in :: [String] -> [String] -> [String]
> let_in ds e = indentWith "let " ds ++ indentWith "in " e

> ppGroundDef :: DGroundDef a -> [String]
> ppGroundDef (DGDefVC d _) = ppDefVertComp d
> ppGroundDef (DGDefVI d _) = ppDefVertInit d
> ppGroundDef (DGDefGV d _) = ppDefGraphVar d 
> ppGroundDef (DGDefGF d _) = ppDefGraphFun d
> ppGroundDef (DGDefSmpl d _) = ppSmplDef d

> ppDefVertComp :: DDefVertComp a -> [String]
> ppDefVertComp (DDefVertComp f ds e _) =
>   if length ds == 0 then indentWith (ppFun f ++ " v prev curr = ") (ppExpr e)
>   else [ppFun f ++" v prev curr = "] ++ indent (let_in (concat $ insList ";" "" $map ppSmplDef ds) (ppExpr e))

> ppDefVertInit :: DDefVertInit a -> [String]
> ppDefVertInit (DDefVertInit f ds e _) =
>   if length ds == 0 then indentWith (ppFun f ++ " v = ") (ppExpr e)
>   else [ppFun f ++" v = "] ++ indent (let_in (concat $ insList ";" "" $map ppSmplDef ds) (ppExpr e))

> ppDefGraphVar :: DDefGraphVar a -> [String]
> ppDefGraphVar (DDefGraphVar v e _) =
>   indentWith (ppVar v ++ " = ") (ppGraphExpr e)
>   

> ppDefGraphFun :: DDefGraphFun a -> [String]
> ppDefGraphFun (DDefGraphFun f v ds e _) =
>   if length ds == 0
>   then header ++ indent (ppGraphExpr e)
>   else header ++ indent (let_in (concat $ insList ";" "" $ map ppDefGraphVar ds) (ppGraphExpr e))
>   where header = [ ppFun f ++ " " ++ (ppVar v) ++ " = " ]

> ppGraphExpr :: DGraphExpr a -> [String]  -- this is a singleton list (of String)
> ppGraphExpr (DPregel f0 ft t g _) =
>   [ppList " " (["fregel", ppFun f0, ppFun ft, ppTermination t] ++ (addParen $ ppGraphExpr g))]
> ppGraphExpr (DGMap f g _) =
>   [ppList " " (["gmap", ppFun f] ++ (addParen $ ppGraphExpr g))]
> ppGraphExpr (DGZip g1 g2 _) =
>   [ppList " " (["gzip"] ++ (addParen $ ppGraphExpr g1) ++ (addParen $ ppGraphExpr g2))]
> ppGraphExpr (DGIter f0 ft t g _) =
>   [ppList " " (["giter", ppFun f0, ppFun ft, ppTermination t] ++ (addParen $ ppGraphExpr g))]
> ppGraphExpr (DGVar g _) = 
>   [ppVar g]
> addParen [s] = ["(" ++ s ++ ")"]

> ppTermination :: DTermination a -> String
> ppTermination (DTermF _)= "Fix"
> ppTermination (DTermI e _) = "(Iter (" ++ ppList " " (ppExpr e) ++ "))"
> ppTermination (DTermU e _) = "(Until (\\g->" ++ ppList " " (ppExpr e) ++ "))"
> ppTermination (DTermV2H _) = "V2H"

> ppSmplDef :: DSmplDef a -> [String]
> ppSmplDef (DDefFun f vs ds e _) =
>   if length ds == 0
>   then header ++ indent (ppExpr e)
>   else header ++ indent (let_in (concat $ insList ";" "" $map ppSmplDef ds) (ppExpr e))
>   where header = [ ppFun f ++ " " ++ ppList " " (map ppVar vs) ++ " = " ]
> ppSmplDef (DDefVar v ds e _) = 
>   if length ds == 0
>   then header ++ indent (ppExpr e)
>   else header ++ indent (let_in (concat $ insList ";" "" $map ppSmplDef ds) (ppExpr e))
>   where header = [ ppVar v ++ " = "]
> ppSmplDef (DDefTuple vs ds e _) = 
>   if length ds == 0
>   then header ++ indent (ppExpr e)
>   else header ++ indent (let_in (concat $ insList ";" "" $map ppSmplDef ds) (ppExpr e))
>   where header = ["(" ++ ppList ", " (map ppVar vs) ++ ") = "]

> ppExpr :: DExpr a-> [String]
> ppExpr (DIf c t e _) = indentWith "if " (ppExpr c) ++
>                        indentWith "then " (ppExpr t) ++
>                        indentWith "else " (ppExpr e)
> ppExpr (DTuple es _) = indentWith "(" (concat $ insList "," ")" $ map ppExpr es)
> ppExpr (DFunAp (DBinOp o _) (e1:e2:[]) _) = [flatE e1 ++ " " ++ o ++ " " ++ flatE e2]
> ppExpr (DFunAp f es _) = [ppList " " (ppFun f: map flatE es)]
> ppExpr (DConsAp c es _) = [ppList " " (ppConstructor c: map flatE es)]
> ppExpr (DFieldAcc e fs _) = [ ppTableExpr e ++ (concat $ map ((".^"++).ppField) fs) ]
> ppExpr (DFieldAccE e fs _) = [ ppEdge e ++ (concat $ map ((".^"++).ppField) fs) ]
> ppExpr (DAggr a e g es _) =
>   [ppAgg a ++ " [ " ++ flatE2 e ++  " | " ++ ppGen g ++ ps ++ " ] "]
>   where ps = if length es == 0 then ""
>              else "," ++ ppList "," (map flatE es)
> ppExpr (DVExp v _) = [ppVar v]
> ppExpr (DCExp c _) = [ppConst c]

> ppTableExpr (DPrev v _) = "prev " ++ ppVar v
> ppTableExpr (DCurr v _) = "curr " ++ ppVar v
> ppTableExpr (DVal v _) = "val " ++ ppVar v

> ppEdge (DEdge _) = "e"

> ppAgg (DAggMin _)  = "minimum"
> ppAgg (DAggMax _)  = "maximum"
> ppAgg (DAggSum _)  = "sum"
> ppAgg (DAggProd _) = "prod"
> ppAgg (DAggAnd _)  = "and"
> ppAgg (DAggOr _)   = "or"
> ppAgg (DAggChoice x _) = "random " ++ flatE x

> ppGen (DGenI _) = "(e, u) <- is v"
> ppGen (DGenO _) = "(e, u) <- rs v"
> ppGen (DGenG _) = "u <- g"
> ppGen (DGenTermG _) = "u <- g"

> flatE :: DExpr a -> String
> flatE = enclose . ppList " " . ppExpr

> flatE2 :: DExpr a -> String
> flatE2 = ppList " " . ppExpr

> enclose :: String -> String
> enclose s = "(" ++ s ++ ")"

> insList :: String -> String -> [[String]] -> [[String]]
> insList c cl sss = map (\(ss, s) -> init ss ++ ((last ss++s):[])) $ reverse $ zip (reverse sss) (cl:repeat c)

> ppField (DField f _) = f
> -- ppField (DFfst _) = "_fst"
> -- ppField (DFsnd _) = "_snd"
> ppFun (DFun f _) = f
> ppFun (DBinOp f _) = "(" ++ f ++ ")"
> ppVar (DVar v _) = v
> ppType (DTInt _) = "Int"
> ppType (DTBool _) = "Bool"
> ppType (DTString _) = "String"
> ppType (DTDouble _) = "Double"
> ppType (DTTuple ts _) = "(" ++ ppList ", " (map ppType ts) ++ ")"
> ppType (DTRecord c [] _) = getName c
> ppType (DTRecord c ts _) = "(" ++ getName c ++ concatMap (" "++) (map ppType ts) ++ ")"
> ppConstructor (DConstructor c _) = c

> ppConst (DCInt i _) = show i
> ppConst (DCBool b _) = show b
> ppConst (DCString s _) = "\"" ++ s ++ "\""
> ppConst (DCDouble d _) = show d



> ppAST :: DProgramSpec a -> String
> ppAST = unlines . ppProgramSpec

> right (Right a) = a
> right (Left a) = error $ show a


> class PrettyShow a where
>     prettyShow :: a -> String

> flattening = removeMultiSpace . ppList " "
> removeMultiSpace s = map fst $ filter (\(a, b) -> not (a == ' ' && b == ' ')) $ zip s ('@':init s)

> instance PrettyShow (DProgramSpec a) where
>     prettyShow = flattening . ppProgramSpec 

> instance PrettyShow (DTermination a) where
>     prettyShow = ppTermination

> instance PrettyShow (DDefGraphFun a) where
>     prettyShow = flattening . ppDefGraphFun

> instance PrettyShow (DDefGraphVar a) where
>     prettyShow = flattening . ppDefGraphVar

> instance PrettyShow (DRecordSpec a) where
>     prettyShow = flattening . ppRecordSpec 

> instance PrettyShow (DProg a) where
>     prettyShow = flattening . ppProg

> instance PrettyShow (DGroundDef a) where
>     prettyShow = flattening . ppGroundDef

> instance PrettyShow (DExpr a) where
>     prettyShow = flattening . ppExpr

> instance PrettyShow (DSmplDef a) where
>     prettyShow = flattening . ppSmplDef

> instance PrettyShow (DDefVertInit a) where
>     prettyShow = flattening . ppDefVertInit

> instance PrettyShow (DDefVertComp a) where
>     prettyShow = flattening . ppDefVertComp

> class DAdditionalData a b | a -> b where
>     getData :: a -> b
>     setData :: b -> a -> a

> instance DAdditionalData (DProgramSpec a) a where
>     getData (DProgramSpec _ _ a) = a
>     setData b (DProgramSpec rs p _) = DProgramSpec rs p b

> instance DAdditionalData (DRecordSpec a) a where
>     getData (DRecordSpec _ _ a) = a
>     setData b (DRecordSpec c fs _) = DRecordSpec c fs b
> instance DAdditionalData (DProg a) a where
>     getData (DProg _ _ _ a) = a
>     setData b (DProg f ds e _) = DProg f ds e b

> instance DAdditionalData (DGroundDef a) a where
>     getData (DGDefVC _ a) = a
>     getData (DGDefVI _ a) = a
>     getData (DGDefGV _ a) = a
>     getData (DGDefGF _ a) = a
>     getData (DGDefSmpl _ a) = a
>     setData b (DGDefVC x _) = DGDefVC x b
>     setData b (DGDefVI x _) = DGDefVI x b
>     setData b (DGDefGV x _) = DGDefGV x b
>     setData b (DGDefGF x _) = DGDefGF x b
>     setData b (DGDefSmpl x _) = DGDefSmpl x b

> instance DAdditionalData (DDefVertComp a) a where
>     getData (DDefVertComp _ _ _ a) = a
>     setData b (DDefVertComp f ds e _) = DDefVertComp f ds e b

> instance DAdditionalData (DDefVertInit a) a where
>     getData (DDefVertInit _ _ _ a) = a
>     setData b (DDefVertInit f ds e _) = DDefVertInit f ds e b

> instance DAdditionalData (DDefGraphVar a) a where
>     getData (DDefGraphVar _ _ a) = a
>     setData b (DDefGraphVar v e _) = DDefGraphVar v e b

> instance DAdditionalData (DDefGraphFun a) a where
>     getData (DDefGraphFun _ _ _  _ a) = a
>     setData b (DDefGraphFun f v ds e _) = DDefGraphFun f v ds e b

> instance DAdditionalData (DGraphExpr a) a where
>     getData (DPregel _ _ _ _ a) = a
>     getData (DGMap _ _ a) = a
>     getData (DGZip _ _ a) = a
>     getData (DGIter _ _ _ _ a) = a
>     getData (DGVar _ a) = a
>     setData b (DPregel f0 ft x g _) = DPregel f0 ft x g b
>     setData b (DGMap f g _) = DGMap f g b
>     setData b (DGZip g1 g2 _) = DGZip g1 g2 b
>     setData b (DGIter f0 ft x g _) = DGIter f0 ft x g b
>     setData b (DGVar g _) = DGVar g b

> instance DAdditionalData (DTermination a) a where
>     getData (DTermF a) = a
>     getData (DTermI _ a) = a
>     getData (DTermU _ a) = a
>     getData (DTermV2H a) = a
>     setData b (DTermF _) = DTermF b
>     setData b (DTermI e _) = DTermI e b
>     setData b (DTermU e _) = DTermU e b
>     setData b (DTermV2H _) = DTermV2H b

> instance DAdditionalData (DSmplDef a) a where
>     getData (DDefFun _ _ _ _ a) = a
>     getData (DDefVar _ _ _ a) = a
>     getData (DDefTuple _ _ _ a) = a
>     setData b (DDefFun f vs ds e _) = DDefFun f vs ds e b
>     setData b (DDefVar v ds e _) = DDefVar v ds e b
>     setData b (DDefTuple vs ds e _) = DDefTuple vs ds e b

> instance DAdditionalData (DExpr a) a where
>     getData (DIf _ _ _ a) = a
>     getData (DTuple _ a) = a
>     getData (DFunAp _ _ a) = a
>     getData (DConsAp _ _ a) = a
>     getData (DFieldAcc _ _ a) = a
>     getData (DFieldAccE _ _ a) = a
>     getData (DAggr _ _ _ _ a) = a
>     getData (DVExp _ a) = a
>     getData (DCExp _ a) = a
>     setData b (DIf p t e _) = DIf p t e b
>     setData b (DTuple es _) = DTuple es b
>     setData b (DFunAp f es _) = DFunAp f es b
>     setData b (DConsAp c es _) = DConsAp c es b
>     setData b (DFieldAcc t fs _) = DFieldAcc t fs b
>     setData b (DFieldAccE e fs _) = DFieldAccE e fs b
>     setData b (DAggr a e g es _) = DAggr a e g es b
>     setData b (DVExp v _) = DVExp v b
>     setData b (DCExp v _) = DCExp v b

> instance DAdditionalData (DGen a) a where
>     getData (DGenI a) = a
>     getData (DGenO a) = a
>     getData (DGenG a) = a
>     getData (DGenTermG a) = a
>     setData b (DGenI _) = DGenI b
>     setData b (DGenO _) = DGenO b
>     setData b (DGenG _) = DGenG b
>     setData b (DGenTermG _) = DGenTermG b

> instance DAdditionalData (DEdge a) a where
>     getData (DEdge a) = a
>     setData b (DEdge _) = DEdge b

> instance DAdditionalData (DTableExpr a) a where
>     getData (DPrev _ a) = a
>     getData (DCurr _ a) = a
>     getData (DVal _ a) = a
>     setData b (DPrev v _) = DPrev v b
>     setData b (DCurr v _) = DCurr v b
>     setData b (DVal v _) = DVal v b


> instance DAdditionalData (DAgg a) a where
>     getData (DAggMin a) = a
>     getData (DAggMax a) = a
>     getData (DAggSum a) = a
>     getData (DAggProd a) = a
>     getData (DAggAnd a) = a
>     getData (DAggOr a) = a
>     getData (DAggChoice x a) = a
>     getData (DTupledAgg _ a) = a
>     setData b (DAggMin _) = DAggMin b
>     setData b (DAggMax _) = DAggMax b
>     setData b (DAggSum _) = DAggSum b
>     setData b (DAggProd _) = DAggProd b
>     setData b (DAggAnd _) = DAggAnd b
>     setData b (DAggOr _) = DAggOr b
>     setData b (DAggChoice x _) = DAggChoice x b
>     setData b (DTupledAgg ags _) = DTupledAgg ags b

> instance DAdditionalData (DConstructor a) a where
>     getData (DConstructor _ a) = a
>     setData b (DConstructor c _) = DConstructor c b

> instance DAdditionalData (DFun a) a where
>     getData (DFun _ a) = a
>     getData (DBinOp _ a) = a
>     setData b (DFun f _) = DFun f b
>     setData b (DBinOp f _) = DBinOp f b

> instance DAdditionalData (DVar a) a where
>     getData (DVar _ a) = a
>     setData b (DVar v _) = DVar v b

> instance DAdditionalData (DField a) a where
>     -- getData (DFfst a) = a
>     -- getData (DFsnd a) = a
>     getData (DField _ a) = a
>     -- setData b (DFfst _) = DFfst b
>     -- setData b (DFsnd _) = DFsnd b
>     setData b (DField f _) = DField f b

> instance DAdditionalData (DConst a) a where
>     getData (DCInt _ a) = a
>     getData (DCBool _ a) = a
>     getData (DCString _ a) = a
>     getData (DCDouble _ a) = a
>     setData b (DCInt c _) = DCInt c b
>     setData b (DCBool c _) = DCBool c b
>     setData b (DCString c _) = DCString c b
>     setData b (DCDouble c _) = DCDouble c b

> instance DAdditionalData (DType a) a where
>     getData (DTInt a) = a
>     getData (DTBool a) = a
>     getData (DTString a) = a
>     getData (DTDouble a) = a
>     getData (DTTuple _ a) = a
>     getData (DTRecord _ _ a) = a
>     setData b (DTInt _) = DTInt b
>     setData b (DTBool _) = DTBool b
>     setData b (DTString _) = DTString b
>     setData b (DTDouble _) = DTDouble b
>     setData b (DTTuple ts _) = DTTuple ts b
>     setData b (DTRecord c fs _) = DTRecord c fs b

> getName :: (DNamed a) => a -> String
> getName = head . getNames

> class DNamed a where
>     getNames :: a -> [String]
>     setNames :: a -> State [String] a

> nextName :: State [String] String
> nextName = do xs <- get; put (tail xs); return (head xs)

> instance DNamed (DFun a) where
>     getNames (DFun f _) = [f]
>     getNames (DBinOp f _) = [f]
>     setNames (DFun _ a) = 
>         do n <- nextName
>            return (DFun n a)
>     setNames (DBinOp _ a) = 
>         do n <- nextName
>            return (DFun n a)

> instance DNamed (DField a) where
>     getNames (DField f _) = [f]
>     setNames (DField _ a) = 
>         do n <- nextName
>            return (DField n a)

> instance DNamed (DVar a) where
>     getNames (DVar f _) = [f]
>     setNames (DVar _ a) = 
>         do n <- nextName
>            return (DVar n a)

> instance DNamed (DConstructor a) where
>     getNames (DConstructor c _) = [c]
>     setNames (DConstructor _ a) = 
>         do n <- nextName
>            return (DConstructor n a)

> instance DNamed (DRecordSpec a) where
>     getNames (DRecordSpec c fts _) = getNames c ++ concatMap getNames (map fst fts)
>     setNames (DRecordSpec c fts a) = 
>         do c' <- setNames c
>            fs' <- mapM setNames (map fst fts)
>            let fts' = zipWith (\ft f -> (f, snd ft)) fts fs'
>            return (DRecordSpec c' fts' a)

> instance DNamed (DGroundDef a) where
>     getNames (DGDefVI d _) = getNames d
>     getNames (DGDefVC d _) = getNames d
>     getNames (DGDefGV d _) = getNames d
>     getNames (DGDefGF d _) = getNames d
>     getNames (DGDefSmpl d _) = getNames d
>     setNames (DGDefVI d a) = do d' <- setNames d; return (DGDefVI d' a)
>     setNames (DGDefVC d a) = do d' <- setNames d; return (DGDefVC d' a)
>     setNames (DGDefGV d a) = do d' <- setNames d; return (DGDefGV d' a)
>     setNames (DGDefGF d a) = do d' <- setNames d; return (DGDefGF d' a)
>     setNames (DGDefSmpl d a) = do d' <- setNames d; return (DGDefSmpl d' a)

> instance DNamed (DProgramSpec a) where
>     getNames (DProgramSpec _ p _) = getNames p
>     setNames (DProgramSpec rs p a) = do p' <- setNames p; return (DProgramSpec rs p' a)

> instance DNamed (DProg a) where
>     getNames (DProg f _ _ _) = getNames f
>     setNames (DProg f ds e a) = do f' <- setNames f; return (DProg f' ds e a)

> instance DNamed (DDefVertComp a) where
>     getNames (DDefVertComp f _ _ _) = getNames f
>     setNames (DDefVertComp f ds e a) = do f' <- setNames f; return (DDefVertComp f' ds e a)

> instance DNamed (DDefVertInit a) where
>     getNames (DDefVertInit f _ _ _) = getNames f
>     setNames (DDefVertInit f ds e a) = do f' <- setNames f; return (DDefVertInit f' ds e a)

> instance DNamed (DDefGraphVar a) where
>     getNames (DDefGraphVar v _ _) = getNames v
>     setNames (DDefGraphVar v e a) = do v' <- setNames v; return (DDefGraphVar v' e a)

> instance DNamed (DDefGraphFun a) where
>     getNames (DDefGraphFun f _ _ _ _) = getNames f
>     setNames (DDefGraphFun f vs ds e a) = do f' <- setNames f; return (DDefGraphFun f' vs ds e a)

> instance DNamed (DSmplDef a) where
>     getNames (DDefFun f _ _ _ _) = getNames f
>     getNames (DDefVar v _ _ _) = getNames v
>     getNames (DDefTuple vs _ _ _) = concatMap getNames vs
>     setNames (DDefFun f vs ds e a) = do f' <- setNames f; return (DDefFun f' vs ds e a)
>     setNames (DDefVar v ds e a) = do v' <- setNames v; return (DDefVar v' ds e a)
>     setNames (DDefTuple vs ds e a) = do vs' <- mapM setNames vs; return (DDefTuple vs' ds e a)

> instance DNamed (DGen a) where
>     getNames (DGenI _) = ["e", "u"]
>     getNames (DGenO _) = ["e", "u"]
>     getNames (DGenG _) = ["u"]
>     getNames (DGenTermG _) = ["u"]
>     setNames (DGenI a) = do nextName; nextName; return (DGenI a)
>     setNames (DGenO a) = do nextName; nextName; return (DGenO a)
>     setNames (DGenG a) = do nextName; return (DGenG a)
>     setNames (DGenTermG a) = do nextName; return (DGenTermG a)


> mmapData f = map (mapData f)

> class DAdditionalData2 a b c d | a c -> b d where
>     mapData :: (b -> c) -> a -> d

> instance DAdditionalData2 (DProgramSpec a) a c (DProgramSpec c) where
>     mapData f (DProgramSpec rs p a) = DProgramSpec (mmapData f rs) (mapData f p) (f a)

> instance DAdditionalData2 (DRecordSpec a) a c (DRecordSpec c) where
>     mapData f (DRecordSpec c fs a) = DRecordSpec (mapData f c) fs' (f a)
>                                      where fs' = zip (mmapData f $ map fst fs) (mmapData f $ map snd fs)
> instance DAdditionalData2 (DProg a) a c (DProg c) where
>     mapData f (DProg f' ds e a) = DProg (mapData f f') (mmapData f ds) (mapData f e) (f a)

> instance DAdditionalData2 (DGroundDef a) a c (DGroundDef c) where
>     mapData f (DGDefVI x a) = DGDefVI (mapData f x) (f a)
>     mapData f (DGDefVC x a) = DGDefVC (mapData f x) (f a)
>     mapData f (DGDefGV x a) = DGDefGV (mapData f x) (f a)
>     mapData f (DGDefGF x a) = DGDefGF (mapData f x) (f a)
>     mapData f (DGDefSmpl x a) = DGDefSmpl (mapData f x) (f a)

> instance DAdditionalData2 (DDefVertComp a) a c (DDefVertComp c) where
>     mapData f (DDefVertComp f' ds e a) = DDefVertComp (mapData f f') (mmapData f ds) (mapData f e) (f a)

> instance DAdditionalData2 (DDefVertInit a) a c (DDefVertInit c) where
>     mapData f (DDefVertInit f' ds e a) = DDefVertInit (mapData f f') (mmapData f ds) (mapData f e) (f a)

> instance DAdditionalData2 (DDefGraphVar a) a c (DDefGraphVar c) where
>     mapData f (DDefGraphVar v e a) = DDefGraphVar (mapData f v) (mapData f e) (f a)

> instance DAdditionalData2 (DDefGraphFun a) a c (DDefGraphFun c) where
>     mapData f (DDefGraphFun f' v ds e a) = DDefGraphFun (mapData f f') (mapData f v) (mmapData f ds) (mapData f e) (f a)

> instance DAdditionalData2 (DGraphExpr a) a c (DGraphExpr c) where
>     mapData f (DPregel f0 ft x g a) = DPregel (mapData f f0) (mapData f ft) (mapData f x) (mapData f g) (f a)
>     mapData f (DGMap f' g a) = DGMap (mapData f f') (mapData f g) (f a)
>     mapData f (DGZip g1 g2 a) = DGZip (mapData f g1) (mapData f g2) (f a)
>     mapData f (DGIter f0 ft x g a) = DGIter (mapData f f0) (mapData f ft) (mapData f x) (mapData f g) (f a)
>     mapData f (DGVar g a) = DGVar (mapData f g) (f a)

> instance DAdditionalData2 (DTermination a) a c (DTermination c) where
>     mapData f (DTermF a) = DTermF (f a)
>     mapData f (DTermI e a) = DTermI (mapData f e) (f a)
>     mapData f (DTermU e a) = DTermU (mapData f e) (f a)
>     mapData f (DTermV2H a) = DTermV2H (f a)

> instance DAdditionalData2 (DSmplDef a) a c (DSmplDef c) where
>     mapData f (DDefFun f' vs ds e a) = DDefFun (mapData f f') (mmapData f vs) (mmapData f ds) (mapData f e) (f a)
>     mapData f (DDefVar v ds e a) = DDefVar (mapData f v) (mmapData f ds) (mapData f e) (f a)
>     mapData f (DDefTuple vs ds e a) = DDefTuple (mmapData f vs) (mmapData f ds) (mapData f e) (f a)

> instance DAdditionalData2 (DExpr a) a c (DExpr c) where
>     mapData f (DIf p t e a) = DIf (mapData f p) (mapData f t) (mapData f e) (f a)
>     mapData f (DTuple es a) = DTuple (mmapData f es) (f a)
>     mapData f (DFunAp f' es a) = DFunAp (mapData f f') (mmapData f es) (f a)
>     mapData f (DConsAp c es a) = DConsAp (mapData f c) (mmapData f es) (f a)
>     mapData f (DFieldAcc t fs a) = DFieldAcc (mapData f t) (mmapData f fs) (f a)
>     mapData f (DFieldAccE e fs a) = DFieldAccE (mapData f e) (mmapData f fs) (f a)
>     mapData f (DAggr a' e g es a) = DAggr (mapData f a') (mapData f e) (mapData f g) (mmapData f es) (f a)
>     mapData f (DVExp v a) = DVExp (mapData f v) (f a)
>     mapData f (DCExp v a) = DCExp (mapData f v) (f a)

> instance DAdditionalData2 (DGen a) a c (DGen c) where
>     mapData f (DGenI a) = DGenI (f a)
>     mapData f (DGenO a) = DGenO (f a)
>     mapData f (DGenG a) = DGenG (f a)
>     mapData f (DGenTermG a) = DGenTermG (f a)

> instance DAdditionalData2 (DEdge a) a c (DEdge c) where
>     mapData f (DEdge a) = DEdge (f a)

> instance DAdditionalData2 (DTableExpr a) a c (DTableExpr c) where
>     mapData f (DPrev v a) = DPrev (mapData f v) (f a)
>     mapData f (DCurr v a) = DCurr (mapData f v) (f a)
>     mapData f (DVal v a) = DVal (mapData f v) (f a)


> instance DAdditionalData2 (DAgg a) a c (DAgg c) where
>     mapData f (DAggMin a) = DAggMin (f a)
>     mapData f (DAggMax a) = DAggMax (f a)
>     mapData f (DAggSum a) = DAggSum (f a)
>     mapData f (DAggProd a) = DAggProd (f a)
>     mapData f (DAggAnd a) = DAggAnd (f a)
>     mapData f (DAggOr a) = DAggOr (f a)
>     mapData f (DAggChoice x a) = DAggChoice (mapData f x) (f a)
>     mapData f (DTupledAgg ags a) = DTupledAgg (mmapData f ags) (f a)

> instance DAdditionalData2 (DConstructor a) a c (DConstructor c) where
>     mapData f (DConstructor c a) = DConstructor c (f a)

> instance DAdditionalData2 (DFun a) a c (DFun c) where
>     mapData f (DFun f' a) = DFun f' (f a)
>     mapData f (DBinOp f' a) = DBinOp f' (f a)

> instance DAdditionalData2 (DVar a) a c (DVar c) where
>     mapData f (DVar v a) = DVar v (f a)

> instance DAdditionalData2 (DField a) a c (DField c) where
>     -- mapData f (DFfst a) = DFfst (f a)
>     -- mapData f (DFsnd a) = DFsnd (f a)
>     mapData f (DField f' a) = DField f' (f a)

> instance DAdditionalData2 (DConst a) a c (DConst c) where
>     mapData f (DCInt c a) = DCInt c (f a)
>     mapData f (DCBool c a) = DCBool c (f a)
>     mapData f (DCString c a) = DCString c (f a)
>     mapData f (DCDouble c a) = DCDouble c (f a)

> instance DAdditionalData2 (DType a) a c (DType c) where
>     mapData f (DTInt a) = DTInt (f a)
>     mapData f (DTBool a) = DTBool (f a)
>     mapData f (DTString a) = DTString (f a)
>     mapData f (DTDouble a) = DTDouble (f a)
>     mapData f (DTTuple ts a) = DTTuple (mmapData f ts) (f a)
>     mapData f (DTRecord c fs a) = DTRecord (mapData f c) (mmapData f fs) (f a)


generaing all subexpressions of the given one

> subExprs :: DExpr a -> [DExpr a]
> subExprs (x@(DIf p t e _)) = x : (subExprs p ++ subExprs t ++ subExprs e)
> subExprs (x@(DTuple es _)) = x : concatMap subExprs es
> subExprs (x@(DFunAp f es _)) = x : concatMap subExprs es
> subExprs (x@(DConsAp c es _)) = x : concatMap subExprs es
> subExprs (x@(DFieldAcc t fs a)) = map (\fs -> DFieldAcc t fs (case fs of [] -> getData t ; otherwise -> getData (last fs))) (reverse $ inits fs) ++ [DVExp v va]
>                                   where v = getTableVar t
>                                         va = getData v
> subExprs (x@(DFieldAccE e fs a)) = map (\fs -> DFieldAccE e fs (case fs of [] -> getData e ; otherwise -> getData (last fs))) (reverse $ inits fs) 
> subExprs (x@(DAggr a e g es _)) = x:subExprs e ++ concatMap subExprs es
> subExprs (x@(DVExp v _)) = [x]
> subExprs (x@(DCExp v _)) = [x]
> getTableVar (DPrev v a) = v
> getTableVar (DCurr v a) = v
> getTableVar (DVal v a) = v


Expression builders

> dd = "" -- dummy data
> 
> expIf p t e = DIf p t e dd
> 
> expBin bop e1 e2 = DFunAp (DBinOp bop dd) [e1, e2] dd
> 
> expFieldAcc tbl v fs = DFieldAcc te (map (\f -> DField f dd) fs) dd
>   where te | tbl == "prev" = DPrev (DVar v dd) dd
>            | tbl == "curr" = DCurr (DVar v dd) dd
>            | tbl == "val"  = DVal  (DVar v dd) dd
> 
> expConstructor c es = DConsAp (DConstructor c dd) es dd
> expConstructor' c es ac a = DConsAp (DConstructor c ac) es a
>
> expFun f es = DFunAp (DFun f dd) es dd
>
> expInt i = DCExp (DCInt i dd) dd
> expBool b = DCExp (DCBool b dd) dd
>
> expVar v = DVExp (DVar v dd) dd
> 
> expAggr agg body gen ps = DAggr agg' body gen' ps dd
>   where agg' | agg == "minimum" = DAggMin dd
>              | agg == "maximum" = DAggMax dd
>              | agg == "sum"     = DAggSum dd
>              | agg == "prod"    = DAggProd dd
>              | agg == "and"     = DAggAnd dd
>              | agg == "or"      = DAggOr dd
>         gen' | gen == "g"       = DGenG dd
>              | gen == "tg"      = DGenTermG dd
>              | gen == "is"      = DGenI dd
>              | gen == "rs"      = DGenO dd
> 
> expCheckTerm v = DCheckTerm (expVar v) dd
>
> defVar v defs e = DDefVar (DVar v dd) defs e dd
>
> defFun f vs defs e = DDefFun (DFun f dd) (map (\v -> DVar v dd) vs) defs e dd
>
> defVertComp f defs e = DDefVertComp (DFun f dd) defs e dd
>
> (^==) = expBin "=="
> (^&&) = expBin "&&"
> (^>) = expBin ">"