diff options
| author | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:54:35 +0000 |
|---|---|---|
| committer | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:54:35 +0000 |
| commit | e9e80fc389365e24d4300d7d5390c7d833a96c50 (patch) | |
| tree | f0b58473adaa670bd8fc52ada419d8cad470ee03 /src/Transfer/Core/Abs.hs | |
| parent | b96b36f43de3e2f8b58d5f539daa6f6d47f25870 (diff) | |
changed names of resource-1.3; added a note on homepage on release
Diffstat (limited to 'src/Transfer/Core/Abs.hs')
| -rw-r--r-- | src/Transfer/Core/Abs.hs | 267 |
1 files changed, 267 insertions, 0 deletions
diff --git a/src/Transfer/Core/Abs.hs b/src/Transfer/Core/Abs.hs new file mode 100644 index 000000000..8306d5b46 --- /dev/null +++ b/src/Transfer/Core/Abs.hs @@ -0,0 +1,267 @@ +{-# 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 |
