mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
268 lines
15 KiB
Haskell
268 lines
15 KiB
Haskell
{-# 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
|