From dbe8e61acc616b8f5ac07e8df89eb98a7997c29d Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Fri, 25 Nov 2005 16:36:19 +0000
Subject: Move transfer into the GF repo.

---
 src/Transfer/Core/Abs.hs | 275 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 275 insertions(+)
 create mode 100644 src/Transfer/Core/Abs.hs

(limited to 'src/Transfer/Core/Abs.hs')

diff --git a/src/Transfer/Core/Abs.hs b/src/Transfer/Core/Abs.hs
new file mode 100644
index 000000000..242cd5a78
--- /dev/null
+++ b/src/Transfer/Core/Abs.hs
@@ -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
-- 
cgit v1.2.3