diff options
Diffstat (limited to 'src/Transfer/Syntax/Abs.hs')
| -rw-r--r-- | src/Transfer/Syntax/Abs.hs | 190 |
1 files changed, 70 insertions, 120 deletions
diff --git a/src/Transfer/Syntax/Abs.hs b/src/Transfer/Syntax/Abs.hs index 9883433eb..cf54d5569 100644 --- a/src/Transfer/Syntax/Abs.hs +++ b/src/Transfer/Syntax/Abs.hs @@ -1,7 +1,8 @@ {-# OPTIONS_GHC -fglasgow-exts #-} -module Transfer.Syntax.Abs where +module Transfer.Syntax.Abs (Tree(..), Module, Import, Decl, ConsDecl, Guard, Pattern, CommaPattern, FieldPattern, Exp, VarOrWild, LetDef, Case, Bind, FieldType, FieldValue, Ident, 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 @@ -112,7 +113,10 @@ data Tree :: * -> * where Ident :: String -> Tree Ident_ composOp :: (forall a. Tree a -> Tree a) -> Tree c -> Tree c -composOp f = head . composOpM (\x -> [f x]) +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 ()) (>>) @@ -123,125 +127,71 @@ 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 imports decls -> return Module `ap` mapM f imports `ap` mapM f decls - Import i -> return Import `ap` f i - DataDecl i exp consdecls -> return DataDecl `ap` f i `ap` f exp `ap` mapM f consdecls - TypeDecl i exp -> return TypeDecl `ap` f i `ap` f exp - ValueDecl i patterns guard exp -> return ValueDecl `ap` f i `ap` mapM f patterns `ap` f guard `ap` f exp - DeriveDecl i0 i1 -> return DeriveDecl `ap` f i0 `ap` f i1 - ConsDecl i exp -> return ConsDecl `ap` f i `ap` f exp - GuardExp exp -> return GuardExp `ap` f exp - POr pattern0 pattern1 -> return POr `ap` f pattern0 `ap` f pattern1 - PListCons pattern0 pattern1 -> return PListCons `ap` f pattern0 `ap` f pattern1 - PConsTop i pattern patterns -> return PConsTop `ap` f i `ap` f pattern `ap` mapM f patterns - PCons i patterns -> return PCons `ap` f i `ap` mapM f patterns - PRec fieldpatterns -> return PRec `ap` mapM f fieldpatterns - PList commapatterns -> return PList `ap` mapM f commapatterns - PTuple commapattern commapatterns -> return PTuple `ap` f commapattern `ap` mapM f commapatterns - PVar i -> return PVar `ap` f i - CommaPattern pattern -> return CommaPattern `ap` f pattern - FieldPattern i pattern -> return FieldPattern `ap` f i `ap` f pattern - EPi varorwild exp0 exp1 -> return EPi `ap` f varorwild `ap` f exp0 `ap` f exp1 - EPiNoVar exp0 exp1 -> return EPiNoVar `ap` f exp0 `ap` f exp1 - EAbs varorwild exp -> return EAbs `ap` f varorwild `ap` f exp - ELet letdefs exp -> return ELet `ap` mapM f letdefs `ap` f exp - ECase exp cases -> return ECase `ap` f exp `ap` mapM f cases - EIf exp0 exp1 exp2 -> return EIf `ap` f exp0 `ap` f exp1 `ap` f exp2 - EDo binds exp -> return EDo `ap` mapM f binds `ap` f exp - EBind exp0 exp1 -> return EBind `ap` f exp0 `ap` f exp1 - EBindC exp0 exp1 -> return EBindC `ap` f exp0 `ap` f exp1 - EOr exp0 exp1 -> return EOr `ap` f exp0 `ap` f exp1 - EAnd exp0 exp1 -> return EAnd `ap` f exp0 `ap` f exp1 - EEq exp0 exp1 -> return EEq `ap` f exp0 `ap` f exp1 - ENe exp0 exp1 -> return ENe `ap` f exp0 `ap` f exp1 - ELt exp0 exp1 -> return ELt `ap` f exp0 `ap` f exp1 - ELe exp0 exp1 -> return ELe `ap` f exp0 `ap` f exp1 - EGt exp0 exp1 -> return EGt `ap` f exp0 `ap` f exp1 - EGe exp0 exp1 -> return EGe `ap` f exp0 `ap` f exp1 - EListCons exp0 exp1 -> return EListCons `ap` f exp0 `ap` f exp1 - EAdd exp0 exp1 -> return EAdd `ap` f exp0 `ap` f exp1 - ESub exp0 exp1 -> return ESub `ap` f exp0 `ap` f exp1 - EMul exp0 exp1 -> return EMul `ap` f exp0 `ap` f exp1 - EDiv exp0 exp1 -> return EDiv `ap` f exp0 `ap` f exp1 - EMod exp0 exp1 -> return EMod `ap` f exp0 `ap` f exp1 - ENeg exp -> return ENeg `ap` f exp - EApp exp0 exp1 -> return EApp `ap` f exp0 `ap` f exp1 - EProj exp i -> return EProj `ap` f exp `ap` f i - ERecType fieldtypes -> return ERecType `ap` mapM f fieldtypes - ERec fieldvalues -> return ERec `ap` mapM f fieldvalues - EList exps -> return EList `ap` mapM f exps - ETuple exp exps -> return ETuple `ap` f exp `ap` mapM f exps - EVar i -> return EVar `ap` f i - VVar i -> return VVar `ap` f i - LetDef i exp -> return LetDef `ap` f i `ap` f exp - Case pattern guard exp -> return Case `ap` f pattern `ap` f guard `ap` f exp - BindVar varorwild exp -> return BindVar `ap` f varorwild `ap` f exp - BindNoVar exp -> return BindNoVar `ap` f exp - FieldType i exp -> return FieldType `ap` f i `ap` f exp - FieldValue i exp -> return FieldValue `ap` f i `ap` f exp - _ -> return t - +newtype C b a = C { unC :: b } composOpFold :: b -> (b -> b -> b) -> (forall a. Tree a -> b) -> Tree c -> b -composOpFold zero combine f t = case t of - Module imports decls -> foldr combine zero (map f imports) `combine` foldr combine zero (map f decls) - Import i -> f i - DataDecl i exp consdecls -> f i `combine` f exp `combine` foldr combine zero (map f consdecls) - TypeDecl i exp -> f i `combine` f exp - ValueDecl i patterns guard exp -> f i `combine` foldr combine zero (map f patterns) `combine` f guard `combine` f exp - DeriveDecl i0 i1 -> f i0 `combine` f i1 - ConsDecl i exp -> f i `combine` f exp - GuardExp exp -> f exp - POr pattern0 pattern1 -> f pattern0 `combine` f pattern1 - PListCons pattern0 pattern1 -> f pattern0 `combine` f pattern1 - PConsTop i pattern patterns -> f i `combine` f pattern `combine` foldr combine zero (map f patterns) - PCons i patterns -> f i `combine` foldr combine zero (map f patterns) - PRec fieldpatterns -> foldr combine zero (map f fieldpatterns) - PList commapatterns -> foldr combine zero (map f commapatterns) - PTuple commapattern commapatterns -> f commapattern `combine` foldr combine zero (map f commapatterns) - PVar i -> f i - CommaPattern pattern -> f pattern - FieldPattern i pattern -> f i `combine` f pattern - EPi varorwild exp0 exp1 -> f varorwild `combine` f exp0 `combine` f exp1 - EPiNoVar exp0 exp1 -> f exp0 `combine` f exp1 - EAbs varorwild exp -> f varorwild `combine` f exp - ELet letdefs exp -> foldr combine zero (map f letdefs) `combine` f exp - ECase exp cases -> f exp `combine` foldr combine zero (map f cases) - EIf exp0 exp1 exp2 -> f exp0 `combine` f exp1 `combine` f exp2 - EDo binds exp -> foldr combine zero (map f binds) `combine` f exp - EBind exp0 exp1 -> f exp0 `combine` f exp1 - EBindC exp0 exp1 -> f exp0 `combine` f exp1 - EOr exp0 exp1 -> f exp0 `combine` f exp1 - EAnd exp0 exp1 -> f exp0 `combine` f exp1 - EEq exp0 exp1 -> f exp0 `combine` f exp1 - ENe exp0 exp1 -> f exp0 `combine` f exp1 - ELt exp0 exp1 -> f exp0 `combine` f exp1 - ELe exp0 exp1 -> f exp0 `combine` f exp1 - EGt exp0 exp1 -> f exp0 `combine` f exp1 - EGe exp0 exp1 -> f exp0 `combine` f exp1 - EListCons exp0 exp1 -> f exp0 `combine` f exp1 - EAdd exp0 exp1 -> f exp0 `combine` f exp1 - ESub exp0 exp1 -> f exp0 `combine` f exp1 - EMul exp0 exp1 -> f exp0 `combine` f exp1 - EDiv exp0 exp1 -> f exp0 `combine` f exp1 - EMod exp0 exp1 -> f exp0 `combine` f exp1 - ENeg exp -> f exp - EApp exp0 exp1 -> f exp0 `combine` f exp1 - EProj exp i -> f exp `combine` f i - ERecType fieldtypes -> foldr combine zero (map f fieldtypes) - ERec fieldvalues -> foldr combine zero (map f fieldvalues) - EList exps -> foldr combine zero (map f exps) - ETuple exp exps -> f exp `combine` foldr combine zero (map f exps) - EVar i -> f i - VVar i -> f i - LetDef i exp -> f i `combine` f exp - Case pattern guard exp -> f pattern `combine` f guard `combine` f exp - BindVar varorwild exp -> f varorwild `combine` f exp - BindNoVar exp -> f exp - FieldType i exp -> f i `combine` f exp - FieldValue i exp -> f i `combine` f exp - _ -> zero +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 imports decls -> r Module `a` foldr (a . a (r (:)) . f) (r []) imports `a` foldr (a . a (r (:)) . f) (r []) decls + Import i -> r Import `a` f i + DataDecl i exp consdecls -> r DataDecl `a` f i `a` f exp `a` foldr (a . a (r (:)) . f) (r []) consdecls + TypeDecl i exp -> r TypeDecl `a` f i `a` f exp + ValueDecl i patterns guard exp -> r ValueDecl `a` f i `a` foldr (a . a (r (:)) . f) (r []) patterns `a` f guard `a` f exp + DeriveDecl i0 i1 -> r DeriveDecl `a` f i0 `a` f i1 + ConsDecl i exp -> r ConsDecl `a` f i `a` f exp + GuardExp exp -> r GuardExp `a` f exp + POr pattern0 pattern1 -> r POr `a` f pattern0 `a` f pattern1 + PListCons pattern0 pattern1 -> r PListCons `a` f pattern0 `a` f pattern1 + PConsTop i pattern patterns -> r PConsTop `a` f i `a` f pattern `a` foldr (a . a (r (:)) . f) (r []) patterns + PCons i patterns -> r PCons `a` f i `a` foldr (a . a (r (:)) . f) (r []) patterns + PRec fieldpatterns -> r PRec `a` foldr (a . a (r (:)) . f) (r []) fieldpatterns + PList commapatterns -> r PList `a` foldr (a . a (r (:)) . f) (r []) commapatterns + PTuple commapattern commapatterns -> r PTuple `a` f commapattern `a` foldr (a . a (r (:)) . f) (r []) commapatterns + PVar i -> r PVar `a` f i + CommaPattern pattern -> r CommaPattern `a` f pattern + FieldPattern i pattern -> r FieldPattern `a` f i `a` f pattern + EPi varorwild exp0 exp1 -> r EPi `a` f varorwild `a` f exp0 `a` f exp1 + EPiNoVar exp0 exp1 -> r EPiNoVar `a` f exp0 `a` f exp1 + EAbs varorwild exp -> r EAbs `a` f varorwild `a` f exp + 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 + EIf exp0 exp1 exp2 -> r EIf `a` f exp0 `a` f exp1 `a` f exp2 + EDo binds exp -> r EDo `a` foldr (a . a (r (:)) . f) (r []) binds `a` f exp + EBind exp0 exp1 -> r EBind `a` f exp0 `a` f exp1 + EBindC exp0 exp1 -> r EBindC `a` f exp0 `a` f exp1 + EOr exp0 exp1 -> r EOr `a` f exp0 `a` f exp1 + EAnd exp0 exp1 -> r EAnd `a` f exp0 `a` f exp1 + EEq exp0 exp1 -> r EEq `a` f exp0 `a` f exp1 + ENe exp0 exp1 -> r ENe `a` f exp0 `a` f exp1 + ELt exp0 exp1 -> r ELt `a` f exp0 `a` f exp1 + ELe exp0 exp1 -> r ELe `a` f exp0 `a` f exp1 + EGt exp0 exp1 -> r EGt `a` f exp0 `a` f exp1 + EGe exp0 exp1 -> r EGe `a` f exp0 `a` f exp1 + EListCons exp0 exp1 -> r EListCons `a` f exp0 `a` f exp1 + EAdd exp0 exp1 -> r EAdd `a` f exp0 `a` f exp1 + ESub exp0 exp1 -> r ESub `a` f exp0 `a` f exp1 + EMul exp0 exp1 -> r EMul `a` f exp0 `a` f exp1 + EDiv exp0 exp1 -> r EDiv `a` f exp0 `a` f exp1 + EMod exp0 exp1 -> r EMod `a` f exp0 `a` f exp1 + ENeg exp -> r ENeg `a` f exp + EApp exp0 exp1 -> r EApp `a` f exp0 `a` f exp1 + EProj exp i -> r EProj `a` f exp `a` f i + ERecType fieldtypes -> r ERecType `a` foldr (a . a (r (:)) . f) (r []) fieldtypes + ERec fieldvalues -> r ERec `a` foldr (a . a (r (:)) . f) (r []) fieldvalues + EList exps -> r EList `a` foldr (a . a (r (:)) . f) (r []) exps + ETuple exp exps -> r ETuple `a` f exp `a` foldr (a . a (r (:)) . f) (r []) exps + EVar i -> r EVar `a` f i + VVar i -> r VVar `a` f i + LetDef i exp -> r LetDef `a` f i `a` f exp + Case pattern guard exp -> r Case `a` f pattern `a` f guard `a` f exp + BindVar varorwild exp -> r BindVar `a` f varorwild `a` f exp + BindNoVar exp -> r BindNoVar `a` f exp + FieldType i exp -> r FieldType `a` f i `a` f exp + FieldValue i exp -> r FieldValue `a` f i `a` f exp + _ -> r t instance Show (Tree c) where showsPrec n t = case t of |