forked from GitHub/gf-core
Move transfer into the GF repo.
This commit is contained in:
bringert
275
src/Transfer/Core/Abs.hs
Normal file
275
src/Transfer/Core/Abs.hs
Normal file
@@ -0,0 +1,275 @@
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module Transfer.Core.Abs where
|
||||
|
||||
import Control.Monad (ap,MonadPlus,msum,mplus,mzero)
|
||||
import Data.Monoid
|
||||
|
||||
-- Haskell module generated by the BNF converter
|
||||
|
||||
data Module_
|
||||
type Module = Tree Module_
|
||||
data Decl_
|
||||
type Decl = Tree Decl_
|
||||
data ConsDecl_
|
||||
type ConsDecl = Tree ConsDecl_
|
||||
data Pattern_
|
||||
type Pattern = Tree Pattern_
|
||||
data FieldPattern_
|
||||
type FieldPattern = Tree FieldPattern_
|
||||
data PatternVariable_
|
||||
type PatternVariable = Tree PatternVariable_
|
||||
data Exp_
|
||||
type Exp = Tree Exp_
|
||||
data LetDef_
|
||||
type LetDef = Tree LetDef_
|
||||
data Case_
|
||||
type Case = Tree Case_
|
||||
data FieldType_
|
||||
type FieldType = Tree FieldType_
|
||||
data FieldValue_
|
||||
type FieldValue = Tree FieldValue_
|
||||
data CIdent_
|
||||
type CIdent = Tree CIdent_
|
||||
|
||||
data Tree :: * -> * where
|
||||
Module :: [Decl] -> Tree Module_
|
||||
DataDecl :: CIdent -> Exp -> [ConsDecl] -> Tree Decl_
|
||||
TypeDecl :: CIdent -> Exp -> Tree Decl_
|
||||
ValueDecl :: CIdent -> Exp -> Tree Decl_
|
||||
ConsDecl :: CIdent -> Exp -> Tree ConsDecl_
|
||||
PCons :: CIdent -> [Pattern] -> Tree Pattern_
|
||||
PVar :: PatternVariable -> Tree Pattern_
|
||||
PRec :: [FieldPattern] -> Tree Pattern_
|
||||
PType :: Tree Pattern_
|
||||
PStr :: String -> Tree Pattern_
|
||||
PInt :: Integer -> Tree Pattern_
|
||||
FieldPattern :: CIdent -> Pattern -> Tree FieldPattern_
|
||||
PVVar :: CIdent -> Tree PatternVariable_
|
||||
PVWild :: Tree PatternVariable_
|
||||
ELet :: [LetDef] -> Exp -> Tree Exp_
|
||||
ECase :: Exp -> [Case] -> Tree Exp_
|
||||
EAbs :: PatternVariable -> Exp -> Tree Exp_
|
||||
EPi :: PatternVariable -> Exp -> Exp -> Tree Exp_
|
||||
EApp :: Exp -> Exp -> Tree Exp_
|
||||
EProj :: Exp -> CIdent -> Tree Exp_
|
||||
EEmptyRec :: Tree Exp_
|
||||
ERecType :: [FieldType] -> Tree Exp_
|
||||
ERec :: [FieldValue] -> Tree Exp_
|
||||
EVar :: CIdent -> Tree Exp_
|
||||
EType :: Tree Exp_
|
||||
EStr :: String -> Tree Exp_
|
||||
EInt :: Integer -> Tree Exp_
|
||||
LetDef :: CIdent -> Exp -> Exp -> Tree LetDef_
|
||||
Case :: Pattern -> Exp -> Tree Case_
|
||||
FieldType :: CIdent -> Exp -> Tree FieldType_
|
||||
FieldValue :: CIdent -> Exp -> Tree FieldValue_
|
||||
CIdent :: String -> Tree CIdent_
|
||||
|
||||
composOp :: (forall a. Tree a -> Tree a) -> Tree c -> Tree c
|
||||
composOp f = head . composOpM (\x -> [f x])
|
||||
|
||||
composOpM_ :: Monad m => (forall a. Tree a -> m ()) -> Tree c -> m ()
|
||||
composOpM_ = composOpFold (return ()) (>>)
|
||||
|
||||
composOpMPlus :: MonadPlus m => (forall a. Tree a -> m b) -> Tree c -> m b
|
||||
composOpMPlus = composOpFold mzero mplus
|
||||
|
||||
composOpMonoid :: Monoid m => (forall a. Tree a -> m) -> Tree c -> m
|
||||
composOpMonoid = composOpFold mempty mappend
|
||||
|
||||
composOpM :: Monad m => (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c)
|
||||
composOpM f t = case t of
|
||||
Module decls -> return Module `ap` mapM f decls
|
||||
DataDecl cident exp consdecls -> return DataDecl `ap` f cident `ap` f exp `ap` mapM f consdecls
|
||||
TypeDecl cident exp -> return TypeDecl `ap` f cident `ap` f exp
|
||||
ValueDecl cident exp -> return ValueDecl `ap` f cident `ap` f exp
|
||||
ConsDecl cident exp -> return ConsDecl `ap` f cident `ap` f exp
|
||||
PCons cident patterns -> return PCons `ap` f cident `ap` mapM f patterns
|
||||
PVar patternvariable -> return PVar `ap` f patternvariable
|
||||
PRec fieldpatterns -> return PRec `ap` mapM f fieldpatterns
|
||||
FieldPattern cident pattern -> return FieldPattern `ap` f cident `ap` f pattern
|
||||
PVVar cident -> return PVVar `ap` f cident
|
||||
ELet letdefs exp -> return ELet `ap` mapM f letdefs `ap` f exp
|
||||
ECase exp cases -> return ECase `ap` f exp `ap` mapM f cases
|
||||
EAbs patternvariable exp -> return EAbs `ap` f patternvariable `ap` f exp
|
||||
EPi patternvariable exp0 exp1 -> return EPi `ap` f patternvariable `ap` f exp0 `ap` f exp1
|
||||
EApp exp0 exp1 -> return EApp `ap` f exp0 `ap` f exp1
|
||||
EProj exp cident -> return EProj `ap` f exp `ap` f cident
|
||||
ERecType fieldtypes -> return ERecType `ap` mapM f fieldtypes
|
||||
ERec fieldvalues -> return ERec `ap` mapM f fieldvalues
|
||||
EVar cident -> return EVar `ap` f cident
|
||||
LetDef cident exp0 exp1 -> return LetDef `ap` f cident `ap` f exp0 `ap` f exp1
|
||||
Case pattern exp -> return Case `ap` f pattern `ap` f exp
|
||||
FieldType cident exp -> return FieldType `ap` f cident `ap` f exp
|
||||
FieldValue cident exp -> return FieldValue `ap` f cident `ap` f exp
|
||||
_ -> return t
|
||||
|
||||
composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b
|
||||
composOpFold zero combine f t = case t of
|
||||
Module decls -> foldr combine zero (map f decls)
|
||||
DataDecl cident exp consdecls -> f cident `combine` f exp `combine` foldr combine zero (map f consdecls)
|
||||
TypeDecl cident exp -> f cident `combine` f exp
|
||||
ValueDecl cident exp -> f cident `combine` f exp
|
||||
ConsDecl cident exp -> f cident `combine` f exp
|
||||
PCons cident patterns -> f cident `combine` foldr combine zero (map f patterns)
|
||||
PVar patternvariable -> f patternvariable
|
||||
PRec fieldpatterns -> foldr combine zero (map f fieldpatterns)
|
||||
FieldPattern cident pattern -> f cident `combine` f pattern
|
||||
PVVar cident -> f cident
|
||||
ELet letdefs exp -> foldr combine zero (map f letdefs) `combine` f exp
|
||||
ECase exp cases -> f exp `combine` foldr combine zero (map f cases)
|
||||
EAbs patternvariable exp -> f patternvariable `combine` f exp
|
||||
EPi patternvariable exp0 exp1 -> f patternvariable `combine` f exp0 `combine` f exp1
|
||||
EApp exp0 exp1 -> f exp0 `combine` f exp1
|
||||
EProj exp cident -> f exp `combine` f cident
|
||||
ERecType fieldtypes -> foldr combine zero (map f fieldtypes)
|
||||
ERec fieldvalues -> foldr combine zero (map f fieldvalues)
|
||||
EVar cident -> f cident
|
||||
LetDef cident exp0 exp1 -> f cident `combine` f exp0 `combine` f exp1
|
||||
Case pattern exp -> f pattern `combine` f exp
|
||||
FieldType cident exp -> f cident `combine` f exp
|
||||
FieldValue cident exp -> f cident `combine` f exp
|
||||
_ -> zero
|
||||
|
||||
instance Show (Tree c) where
|
||||
showsPrec n t = case t of
|
||||
Module decls -> opar n . showString "Module" . showChar ' ' . showsPrec 1 decls . cpar n
|
||||
DataDecl cident exp consdecls -> opar n . showString "DataDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 consdecls . cpar n
|
||||
TypeDecl cident exp -> opar n . showString "TypeDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
ValueDecl cident exp -> opar n . showString "ValueDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
ConsDecl cident exp -> opar n . showString "ConsDecl" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
PCons cident patterns -> opar n . showString "PCons" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 patterns . cpar n
|
||||
PVar patternvariable -> opar n . showString "PVar" . showChar ' ' . showsPrec 1 patternvariable . cpar n
|
||||
PRec fieldpatterns -> opar n . showString "PRec" . showChar ' ' . showsPrec 1 fieldpatterns . cpar n
|
||||
PType -> showString "PType"
|
||||
PStr str -> opar n . showString "PStr" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
PInt n -> opar n . showString "PInt" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
FieldPattern cident pattern -> opar n . showString "FieldPattern" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 pattern . cpar n
|
||||
PVVar cident -> opar n . showString "PVVar" . showChar ' ' . showsPrec 1 cident . cpar n
|
||||
PVWild -> showString "PVWild"
|
||||
ELet letdefs exp -> opar n . showString "ELet" . showChar ' ' . showsPrec 1 letdefs . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
ECase exp cases -> opar n . showString "ECase" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cases . cpar n
|
||||
EAbs patternvariable exp -> opar n . showString "EAbs" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
EPi patternvariable exp0 exp1 -> opar n . showString "EPi" . showChar ' ' . showsPrec 1 patternvariable . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
|
||||
EApp exp0 exp1 -> opar n . showString "EApp" . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
|
||||
EProj exp cident -> opar n . showString "EProj" . showChar ' ' . showsPrec 1 exp . showChar ' ' . showsPrec 1 cident . cpar n
|
||||
EEmptyRec -> showString "EEmptyRec"
|
||||
ERecType fieldtypes -> opar n . showString "ERecType" . showChar ' ' . showsPrec 1 fieldtypes . cpar n
|
||||
ERec fieldvalues -> opar n . showString "ERec" . showChar ' ' . showsPrec 1 fieldvalues . cpar n
|
||||
EVar cident -> opar n . showString "EVar" . showChar ' ' . showsPrec 1 cident . cpar n
|
||||
EType -> showString "EType"
|
||||
EStr str -> opar n . showString "EStr" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
EInt n -> opar n . showString "EInt" . showChar ' ' . showsPrec 1 n . cpar n
|
||||
LetDef cident exp0 exp1 -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . cpar n
|
||||
Case pattern exp -> opar n . showString "Case" . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
FieldType cident exp -> opar n . showString "FieldType" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
FieldValue cident exp -> opar n . showString "FieldValue" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . cpar n
|
||||
CIdent str -> opar n . showString "CIdent" . showChar ' ' . showsPrec 1 str . cpar n
|
||||
where opar n = if n > 0 then showChar '(' else id
|
||||
cpar n = if n > 0 then showChar ')' else id
|
||||
|
||||
instance Eq (Tree c) where (==) = johnMajorEq
|
||||
|
||||
johnMajorEq :: Tree a -> Tree b -> Bool
|
||||
johnMajorEq (Module decls) (Module decls_) = decls == decls_
|
||||
johnMajorEq (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = cident == cident_ && exp == exp_ && consdecls == consdecls_
|
||||
johnMajorEq (TypeDecl cident exp) (TypeDecl cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (ValueDecl cident exp) (ValueDecl cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (ConsDecl cident exp) (ConsDecl cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (PCons cident patterns) (PCons cident_ patterns_) = cident == cident_ && patterns == patterns_
|
||||
johnMajorEq (PVar patternvariable) (PVar patternvariable_) = patternvariable == patternvariable_
|
||||
johnMajorEq (PRec fieldpatterns) (PRec fieldpatterns_) = fieldpatterns == fieldpatterns_
|
||||
johnMajorEq PType PType = True
|
||||
johnMajorEq (PStr str) (PStr str_) = str == str_
|
||||
johnMajorEq (PInt n) (PInt n_) = n == n_
|
||||
johnMajorEq (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = cident == cident_ && pattern == pattern_
|
||||
johnMajorEq (PVVar cident) (PVVar cident_) = cident == cident_
|
||||
johnMajorEq PVWild PVWild = True
|
||||
johnMajorEq (ELet letdefs exp) (ELet letdefs_ exp_) = letdefs == letdefs_ && exp == exp_
|
||||
johnMajorEq (ECase exp cases) (ECase exp_ cases_) = exp == exp_ && cases == cases_
|
||||
johnMajorEq (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = patternvariable == patternvariable_ && exp == exp_
|
||||
johnMajorEq (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = patternvariable == patternvariable_ && exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (EApp exp0 exp1) (EApp exp0_ exp1_) = exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (EProj exp cident) (EProj exp_ cident_) = exp == exp_ && cident == cident_
|
||||
johnMajorEq EEmptyRec EEmptyRec = True
|
||||
johnMajorEq (ERecType fieldtypes) (ERecType fieldtypes_) = fieldtypes == fieldtypes_
|
||||
johnMajorEq (ERec fieldvalues) (ERec fieldvalues_) = fieldvalues == fieldvalues_
|
||||
johnMajorEq (EVar cident) (EVar cident_) = cident == cident_
|
||||
johnMajorEq EType EType = True
|
||||
johnMajorEq (EStr str) (EStr str_) = str == str_
|
||||
johnMajorEq (EInt n) (EInt n_) = n == n_
|
||||
johnMajorEq (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = cident == cident_ && exp0 == exp0_ && exp1 == exp1_
|
||||
johnMajorEq (Case pattern exp) (Case pattern_ exp_) = pattern == pattern_ && exp == exp_
|
||||
johnMajorEq (FieldType cident exp) (FieldType cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (FieldValue cident exp) (FieldValue cident_ exp_) = cident == cident_ && exp == exp_
|
||||
johnMajorEq (CIdent str) (CIdent str_) = str == str_
|
||||
johnMajorEq _ _ = False
|
||||
|
||||
instance Ord (Tree c) where
|
||||
compare x y = compare (index x) (index y) `mappend` compareSame x y
|
||||
where
|
||||
index (Module _) = 0
|
||||
index (DataDecl _ _ _) = 1
|
||||
index (TypeDecl _ _) = 2
|
||||
index (ValueDecl _ _) = 3
|
||||
index (ConsDecl _ _) = 4
|
||||
index (PCons _ _) = 5
|
||||
index (PVar _) = 6
|
||||
index (PRec _) = 7
|
||||
index (PType ) = 8
|
||||
index (PStr _) = 9
|
||||
index (PInt _) = 10
|
||||
index (FieldPattern _ _) = 11
|
||||
index (PVVar _) = 12
|
||||
index (PVWild ) = 13
|
||||
index (ELet _ _) = 14
|
||||
index (ECase _ _) = 15
|
||||
index (EAbs _ _) = 16
|
||||
index (EPi _ _ _) = 17
|
||||
index (EApp _ _) = 18
|
||||
index (EProj _ _) = 19
|
||||
index (EEmptyRec ) = 20
|
||||
index (ERecType _) = 21
|
||||
index (ERec _) = 22
|
||||
index (EVar _) = 23
|
||||
index (EType ) = 24
|
||||
index (EStr _) = 25
|
||||
index (EInt _) = 26
|
||||
index (LetDef _ _ _) = 27
|
||||
index (Case _ _) = 28
|
||||
index (FieldType _ _) = 29
|
||||
index (FieldValue _ _) = 30
|
||||
index (CIdent _) = 31
|
||||
compareSame (Module decls) (Module decls_) = compare decls decls_
|
||||
compareSame (DataDecl cident exp consdecls) (DataDecl cident_ exp_ consdecls_) = mappend (compare cident cident_) (mappend (compare exp exp_) (compare consdecls consdecls_))
|
||||
compareSame (TypeDecl cident exp) (TypeDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (ValueDecl cident exp) (ValueDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (ConsDecl cident exp) (ConsDecl cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (PCons cident patterns) (PCons cident_ patterns_) = mappend (compare cident cident_) (compare patterns patterns_)
|
||||
compareSame (PVar patternvariable) (PVar patternvariable_) = compare patternvariable patternvariable_
|
||||
compareSame (PRec fieldpatterns) (PRec fieldpatterns_) = compare fieldpatterns fieldpatterns_
|
||||
compareSame PType PType = EQ
|
||||
compareSame (PStr str) (PStr str_) = compare str str_
|
||||
compareSame (PInt n) (PInt n_) = compare n n_
|
||||
compareSame (FieldPattern cident pattern) (FieldPattern cident_ pattern_) = mappend (compare cident cident_) (compare pattern pattern_)
|
||||
compareSame (PVVar cident) (PVVar cident_) = compare cident cident_
|
||||
compareSame PVWild PVWild = EQ
|
||||
compareSame (ELet letdefs exp) (ELet letdefs_ exp_) = mappend (compare letdefs letdefs_) (compare exp exp_)
|
||||
compareSame (ECase exp cases) (ECase exp_ cases_) = mappend (compare exp exp_) (compare cases cases_)
|
||||
compareSame (EAbs patternvariable exp) (EAbs patternvariable_ exp_) = mappend (compare patternvariable patternvariable_) (compare exp exp_)
|
||||
compareSame (EPi patternvariable exp0 exp1) (EPi patternvariable_ exp0_ exp1_) = mappend (compare patternvariable patternvariable_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
|
||||
compareSame (EApp exp0 exp1) (EApp exp0_ exp1_) = mappend (compare exp0 exp0_) (compare exp1 exp1_)
|
||||
compareSame (EProj exp cident) (EProj exp_ cident_) = mappend (compare exp exp_) (compare cident cident_)
|
||||
compareSame EEmptyRec EEmptyRec = EQ
|
||||
compareSame (ERecType fieldtypes) (ERecType fieldtypes_) = compare fieldtypes fieldtypes_
|
||||
compareSame (ERec fieldvalues) (ERec fieldvalues_) = compare fieldvalues fieldvalues_
|
||||
compareSame (EVar cident) (EVar cident_) = compare cident cident_
|
||||
compareSame EType EType = EQ
|
||||
compareSame (EStr str) (EStr str_) = compare str str_
|
||||
compareSame (EInt n) (EInt n_) = compare n n_
|
||||
compareSame (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = mappend (compare cident cident_) (mappend (compare exp0 exp0_) (compare exp1 exp1_))
|
||||
compareSame (Case pattern exp) (Case pattern_ exp_) = mappend (compare pattern pattern_) (compare exp exp_)
|
||||
compareSame (FieldType cident exp) (FieldType cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (FieldValue cident exp) (FieldValue cident_ exp_) = mappend (compare cident cident_) (compare exp exp_)
|
||||
compareSame (CIdent str) (CIdent str_) = compare str str_
|
||||
compareSame x y = error "BNFC error:" compareSame
|
||||
Reference in New Issue
Block a user