diff options
Diffstat (limited to 'src/Transfer/Core/Abs.hs')
| -rw-r--r-- | src/Transfer/Core/Abs.hs | 267 |
1 files changed, 0 insertions, 267 deletions
diff --git a/src/Transfer/Core/Abs.hs b/src/Transfer/Core/Abs.hs deleted file mode 100644 index 8306d5b46..000000000 --- a/src/Transfer/Core/Abs.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -module Transfer.Core.Abs (Tree(..), Module, Decl, ConsDecl, Pattern, FieldPattern, PatternVariable, Exp, LetDef, Case, FieldType, FieldValue, TMeta, CIdent, composOp, composOpM, composOpM_, composOpMPlus, composOpMonoid, composOpFold, compos, johnMajorEq) where - -import Control.Monad (ap,MonadPlus,msum,mplus,mzero) -import Control.Monad.Identity -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_ - 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 -> 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 = runIdentity . composOpM (Identity . f) - -composOpM :: Monad m => (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c) -composOpM = compos return ap - -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 - -newtype C b a = C { unC :: b } -composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b -composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) - -compos :: (forall a. a -> m a) - -> (forall a b. m (a -> b) -> m a -> m b) - -> (forall a. Tree a -> m (Tree a)) -> Tree c -> m (Tree c) -compos r a f t = case t of - Module decls -> r Module `a` foldr (a . a (r (:)) . f) (r []) decls - DataDecl cident exp consdecls -> r DataDecl `a` f cident `a` f exp `a` foldr (a . a (r (:)) . f) (r []) consdecls - TypeDecl cident exp -> r TypeDecl `a` f cident `a` f exp - ValueDecl cident exp -> r ValueDecl `a` f cident `a` f exp - ConsDecl cident exp -> r ConsDecl `a` f cident `a` f exp - PCons cident patterns -> r PCons `a` f cident `a` foldr (a . a (r (:)) . f) (r []) patterns - PVar patternvariable -> r PVar `a` f patternvariable - PRec fieldpatterns -> r PRec `a` foldr (a . a (r (:)) . f) (r []) fieldpatterns - FieldPattern cident pattern -> r FieldPattern `a` f cident `a` f pattern - PVVar cident -> r PVVar `a` f cident - ELet letdefs exp -> r ELet `a` foldr (a . a (r (:)) . f) (r []) letdefs `a` f exp - ECase exp cases -> r ECase `a` f exp `a` foldr (a . a (r (:)) . f) (r []) cases - EAbs patternvariable exp -> r EAbs `a` f patternvariable `a` f exp - EPi patternvariable exp0 exp1 -> r EPi `a` f patternvariable `a` f exp0 `a` f exp1 - EApp exp0 exp1 -> r EApp `a` f exp0 `a` f exp1 - EProj exp cident -> r EProj `a` f exp `a` f cident - ERecType fieldtypes -> r ERecType `a` foldr (a . a (r (:)) . f) (r []) fieldtypes - ERec fieldvalues -> r ERec `a` foldr (a . a (r (:)) . f) (r []) fieldvalues - EVar cident -> r EVar `a` f cident - EMeta tmeta -> r EMeta `a` f tmeta - LetDef cident exp -> r LetDef `a` f cident `a` f exp - Case pattern exp0 exp1 -> r Case `a` f pattern `a` f exp0 `a` f exp1 - FieldType cident exp -> r FieldType `a` f cident `a` f exp - FieldValue cident exp -> r FieldValue `a` f cident `a` f exp - _ -> r t - -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 - 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 exp -> opar n . showString "LetDef" . showChar ' ' . showsPrec 1 cident . showChar ' ' . showsPrec 1 exp . 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 (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 exp) (LetDef cident_ exp_) = cident == cident_ && exp == exp_ -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 -index :: Tree c -> Int -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 (PStr _) = 8 -index (PInt _) = 9 -index (FieldPattern _ _) = 10 -index (PVVar _) = 11 -index (PVWild ) = 12 -index (ELet _ _) = 13 -index (ECase _ _) = 14 -index (EAbs _ _) = 15 -index (EPi _ _ _) = 16 -index (EApp _ _) = 17 -index (EProj _ _) = 18 -index (ERecType _) = 19 -index (ERec _) = 20 -index (EVar _) = 21 -index (EType ) = 22 -index (EStr _) = 23 -index (EInteger _) = 24 -index (EDouble _) = 25 -index (EMeta _) = 26 -index (LetDef _ _) = 27 -index (Case _ _ _) = 28 -index (FieldType _ _) = 29 -index (FieldValue _ _) = 30 -index (TMeta _) = 31 -index (CIdent _) = 32 -compareSame :: Tree c -> Tree c -> Ordering -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 (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 exp) (LetDef cident_ exp_) = mappend (compare cident cident_) (compare exp exp_) -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 |