{-# 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 TMeta_ type TMeta = Tree TMeta_ 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_ ERecType :: [FieldType] -> Tree Exp_ ERec :: [FieldValue] -> Tree Exp_ EVar :: CIdent -> Tree Exp_ EType :: Tree Exp_ EStr :: String -> Tree Exp_ EInteger :: Integer -> Tree Exp_ EDouble :: Double -> Tree Exp_ EMeta :: TMeta -> Tree Exp_ LetDef :: CIdent -> Exp -> Exp -> Tree LetDef_ Case :: Pattern -> Exp -> Exp -> Tree Case_ FieldType :: CIdent -> Exp -> Tree FieldType_ FieldValue :: CIdent -> Exp -> Tree FieldValue_ TMeta :: String -> Tree TMeta_ 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 EMeta tmeta -> return EMeta `ap` f tmeta LetDef cident exp0 exp1 -> return LetDef `ap` f cident `ap` f exp0 `ap` f exp1 Case pattern exp0 exp1 -> return Case `ap` f pattern `ap` f exp0 `ap` f exp1 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 EMeta tmeta -> f tmeta LetDef cident exp0 exp1 -> f cident `combine` f exp0 `combine` f exp1 Case pattern exp0 exp1 -> f pattern `combine` f exp0 `combine` f exp1 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 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 EInteger n -> opar n . showString "EInteger" . showChar ' ' . showsPrec 1 n . cpar n EDouble d -> opar n . showString "EDouble" . showChar ' ' . showsPrec 1 d . cpar n EMeta tmeta -> opar n . showString "EMeta" . showChar ' ' . showsPrec 1 tmeta . 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 exp0 exp1 -> opar n . showString "Case" . showChar ' ' . showsPrec 1 pattern . showChar ' ' . showsPrec 1 exp0 . showChar ' ' . showsPrec 1 exp1 . 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 TMeta str -> opar n . showString "TMeta" . showChar ' ' . showsPrec 1 str . 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 (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 (EInteger n) (EInteger n_) = n == n_ johnMajorEq (EDouble d) (EDouble d_) = d == d_ johnMajorEq (EMeta tmeta) (EMeta tmeta_) = tmeta == tmeta_ johnMajorEq (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = cident == cident_ && exp0 == exp0_ && exp1 == exp1_ johnMajorEq (Case pattern exp0 exp1) (Case pattern_ exp0_ exp1_) = pattern == pattern_ && exp0 == exp0_ && exp1 == exp1_ johnMajorEq (FieldType cident exp) (FieldType cident_ exp_) = cident == cident_ && exp == exp_ johnMajorEq (FieldValue cident exp) (FieldValue cident_ exp_) = cident == cident_ && exp == exp_ johnMajorEq (TMeta str) (TMeta str_) = str == str_ 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 (ERecType _) = 20 index (ERec _) = 21 index (EVar _) = 22 index (EType ) = 23 index (EStr _) = 24 index (EInteger _) = 25 index (EDouble _) = 26 index (EMeta _) = 27 index (LetDef _ _ _) = 28 index (Case _ _ _) = 29 index (FieldType _ _) = 30 index (FieldValue _ _) = 31 index (TMeta _) = 32 index (CIdent _) = 33 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 (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 (EInteger n) (EInteger n_) = compare n n_ compareSame (EDouble d) (EDouble d_) = compare d d_ compareSame (EMeta tmeta) (EMeta tmeta_) = compare tmeta tmeta_ compareSame (LetDef cident exp0 exp1) (LetDef cident_ exp0_ exp1_) = mappend (compare cident cident_) (mappend (compare exp0 exp0_) (compare exp1 exp1_)) compareSame (Case pattern exp0 exp1) (Case pattern_ exp0_ exp1_) = mappend (compare pattern pattern_) (mappend (compare exp0 exp0_) (compare exp1 exp1_)) 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 (TMeta str) (TMeta str_) = compare str str_ compareSame (CIdent str) (CIdent str_) = compare str str_ compareSame x y = error "BNFC error:" compareSame