├── .github └── workflows │ └── ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── benchmark-results ├── hoas-7.1.csv ├── results-6.12-o2-strict.csv ├── results-6.12-o2-uncxt.csv ├── results-7.0.2.ods ├── results-7.1-o2-strict.csv ├── results-7.1-o2-uncxt.csv ├── results-7.1-o2.csv ├── results-7.21.ods ├── results-7.4-o2-fllvm.ods ├── results-7.4-o2.ods ├── results-corrected.xlsx ├── results-ghc7.1-gen.ods ├── results-ghc7.1-o1.ods ├── results-ghc7.1-o2'.ods ├── results-ghc7.1-o2-strict.ods ├── results-ghc7.1-o2-uncxt.ods ├── results-ghc7.1-o2.ods ├── results-ghc7.1-xmap.csv ├── results-o0.ods ├── results-o1.ods ├── results-o2-mac.ods ├── results-o2-strict.ods ├── results-o2-uncxt.ods └── results-o2.ods ├── benchmark ├── Benchmark.hs ├── DataTypes.hs ├── DataTypes │ ├── Comp.hs │ ├── Standard.hs │ └── Transform.hs ├── Functions.hs ├── Functions │ ├── Comp.hs │ ├── Comp │ │ ├── Desugar.hs │ │ ├── Eval.hs │ │ ├── FreeVars.hs │ │ ├── HOAS.hs │ │ └── Inference.hs │ ├── Standard.hs │ └── Standard │ │ ├── Desugar.hs │ │ ├── Eval.hs │ │ ├── FreeVars.hs │ │ └── Inference.hs ├── Multi │ ├── DataTypes │ │ └── Comp.hs │ └── Functions │ │ └── Comp │ │ ├── Desugar.hs │ │ └── Eval.hs ├── Param │ └── DataTypes │ │ ├── Comp.hs │ │ ├── Standard.hs │ │ └── Transform.hs ├── Test.hs └── Transformations.hs ├── compdata.cabal ├── examples └── Examples │ ├── Common.hs │ ├── Desugar.hs │ ├── Eval.hs │ ├── EvalM.hs │ ├── Multi │ ├── Common.hs │ ├── Desugar.hs │ ├── Eval.hs │ ├── EvalI.hs │ └── EvalM.hs │ └── Thunk.hs ├── runbenchmarks ├── src └── Data │ ├── Comp.hs │ └── Comp │ ├── Algebra.hs │ ├── Annotation.hs │ ├── Arbitrary.hs │ ├── Decompose.hs │ ├── DeepSeq.hs │ ├── Derive.hs │ ├── Derive │ ├── Arbitrary.hs │ ├── DeepSeq.hs │ ├── Equality.hs │ ├── Foldable.hs │ ├── HaskellStrict.hs │ ├── LiftSum.hs │ ├── Ordering.hs │ ├── Show.hs │ ├── SmartAConstructors.hs │ ├── SmartConstructors.hs │ ├── Traversable.hs │ └── Utils.hs │ ├── Desugar.hs │ ├── Equality.hs │ ├── Generic.hs │ ├── Mapping.hs │ ├── Matching.hs │ ├── Multi.hs │ ├── Multi │ ├── Algebra.hs │ ├── Annotation.hs │ ├── Derive.hs │ ├── Derive │ │ ├── Equality.hs │ │ ├── HFoldable.hs │ │ ├── HFunctor.hs │ │ ├── HTraversable.hs │ │ ├── LiftSum.hs │ │ ├── Ordering.hs │ │ ├── Show.hs │ │ ├── SmartAConstructors.hs │ │ └── SmartConstructors.hs │ ├── Desugar.hs │ ├── Equality.hs │ ├── Generic.hs │ ├── HFoldable.hs │ ├── HFunctor.hs │ ├── HTraversable.hs │ ├── Mapping.hs │ ├── Ops.hs │ ├── Ordering.hs │ ├── Projection.hs │ ├── Show.hs │ ├── Sum.hs │ ├── Term.hs │ └── Variables.hs │ ├── Ops.hs │ ├── Ordering.hs │ ├── Projection.hs │ ├── Render.hs │ ├── Show.hs │ ├── SubsumeCommon.hs │ ├── Sum.hs │ ├── Term.hs │ ├── TermRewriting.hs │ ├── Thunk.hs │ ├── Unification.hs │ └── Variables.hs ├── testsuite └── tests │ ├── Data │ ├── Comp │ │ ├── Equality_Test.hs │ │ ├── Examples │ │ │ ├── Comp.hs │ │ │ └── Multi.hs │ │ ├── Examples_Test.hs │ │ ├── Multi │ │ │ └── Variables_Test.hs │ │ ├── Multi_Test.hs │ │ ├── Subsume_Test.hs │ │ └── Variables_Test.hs │ └── Comp_Test.hs │ ├── Data_Test.hs │ └── Test │ └── Utils.hs └── upload-doc /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | paths-ignore: 7 | - 'docs/**' 8 | - '*.md' 9 | pull_request: 10 | types: 11 | - opened 12 | - synchronize 13 | paths-ignore: 14 | - 'docs/**' 15 | - '*.md' 16 | jobs: 17 | build: 18 | runs-on: ubuntu-latest 19 | strategy: 20 | matrix: 21 | cabal: ["3.10.1.0"] 22 | ghc: ["9.2", "9.4" , "9.6" , "9.8"] 23 | env: 24 | CONFIG: "--enable-tests" 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: haskell-actions/setup@v2 28 | id: setup-haskell-cabal 29 | with: 30 | ghc-version: ${{ matrix.ghc }} 31 | cabal-version: ${{ matrix.cabal }} 32 | cabal-update: true 33 | - name: Configure 34 | run: cabal configure $CONFIG 35 | - name: Ensure buildability with GHC-shipped versions of dependencies 36 | # Fix all GHC-shipped libraries to their installed version. 37 | # This list is a superset of libraries that are actually used during the build, 38 | # but this does not matter, as it does not entail that all these libraries are built. 39 | run: | 40 | cat >> cabal.project.local < String -> String -> String 67 | showBinOp op x y = "("++ x ++ op ++ y ++ ")" 68 | 69 | instance Show SExpr where 70 | show (SInt i) = show i 71 | show (SBool b) = show b 72 | show (SPair x y) = showBinOp "," (show x) (show y) 73 | 74 | instance Show OExpr where 75 | show (OInt i) = show i 76 | show (OBool b) = show b 77 | show (OPair x y) = showBinOp "," (show x) (show y) 78 | show (OPlus x y) = showBinOp "+" (show x) (show y) 79 | show (OMult x y) = showBinOp "*" (show x) (show y) 80 | show (OIf b x y) = "if " ++ show b ++ " then " ++ show x ++ " else " ++ show y ++ " fi" 81 | show (OEq x y) = showBinOp "==" (show x) (show y) 82 | show (OLt x y) = showBinOp "<" (show x) (show y) 83 | show (OAnd x y) = showBinOp "&&" (show x) (show y) 84 | show (ONot x) = "~" ++ (show x) 85 | show (OProj SProjLeft x) = (show x) ++ "!0" 86 | show (OProj SProjRight x) = (show x) ++ "!1" 87 | 88 | instance Show VType where 89 | show VTInt = "Int" 90 | show VTBool = "Bool" 91 | show (VTPair x y) = "(" ++ show x ++ "," ++ show y ++ ")" 92 | -------------------------------------------------------------------------------- /benchmark/DataTypes/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TemplateHaskell, 3 | MultiParamTypeClasses, 4 | FlexibleInstances, 5 | FlexibleContexts, 6 | UndecidableInstances, 7 | TypeOperators, 8 | ScopedTypeVariables, 9 | TypeSynonymInstances #-} 10 | 11 | module DataTypes.Transform where 12 | 13 | import Data.Comp 14 | import Data.Comp.Derive 15 | import DataTypes.Standard as S 16 | import DataTypes.Comp 17 | 18 | class TransSugar f where 19 | transSugarAlg :: Alg f PExpr 20 | 21 | transSugar :: (Functor f, TransSugar f) => Term f -> PExpr 22 | transSugar = cata transSugarAlg 23 | 24 | $(derive [liftSum] [''TransSugar]) 25 | 26 | instance TransSugar Value where 27 | transSugarAlg (VInt i) = PInt i 28 | transSugarAlg (VBool b) = PBool b 29 | transSugarAlg (VPair x y) = PPair x y 30 | 31 | instance TransSugar Op where 32 | transSugarAlg (Plus x y) = PPlus x y 33 | transSugarAlg (Mult x y) = PMult x y 34 | transSugarAlg (If b x y) = PIf b x y 35 | transSugarAlg (Lt x y) = PLt x y 36 | transSugarAlg (And x y) = PAnd x y 37 | transSugarAlg (Not x) = PNot x 38 | transSugarAlg (Proj p x) = PProj (ptrans p) x 39 | where ptrans ProjLeft = SProjLeft 40 | ptrans ProjRight = SProjRight 41 | transSugarAlg (Eq x y) = PEq x y 42 | 43 | instance TransSugar Sugar where 44 | transSugarAlg (Neg x) = PNeg x 45 | transSugarAlg (Minus x y) = PMinus x y 46 | transSugarAlg (Gt x y) = PGt x y 47 | transSugarAlg (Or x y) = POr x y 48 | transSugarAlg (Impl x y) = PImpl x y 49 | 50 | 51 | 52 | class TransCore f where 53 | transCoreAlg :: Alg f OExpr 54 | 55 | transCore :: (Functor f, TransCore f) => Term f -> OExpr 56 | transCore = cata transCoreAlg 57 | 58 | $(derive [liftSum] [''TransCore]) 59 | 60 | instance TransCore Value where 61 | transCoreAlg (VInt i) = OInt i 62 | transCoreAlg (VBool b) = OBool b 63 | transCoreAlg (VPair x y) = OPair x y 64 | 65 | instance TransCore Op where 66 | transCoreAlg (Plus x y) = OPlus x y 67 | transCoreAlg (Mult x y) = OMult x y 68 | transCoreAlg (If b x y) = OIf b x y 69 | transCoreAlg (Lt x y) = OLt x y 70 | transCoreAlg (And x y) = OAnd x y 71 | transCoreAlg (Not x) = ONot x 72 | transCoreAlg (Proj p x) = OProj (ptrans p) x 73 | where ptrans ProjLeft = SProjLeft 74 | ptrans ProjRight = SProjRight 75 | transCoreAlg (Eq x y) = OEq x y 76 | 77 | class TransVal f where 78 | transValAlg :: Alg f SExpr 79 | 80 | transVal :: (Functor f, TransVal f) => Term f -> SExpr 81 | transVal = cata transValAlg 82 | 83 | $(derive [liftSum] [''TransVal]) 84 | 85 | instance TransVal Value where 86 | transValAlg (VInt i) = SInt i 87 | transValAlg (VBool b) = SBool b 88 | transValAlg (VPair x y) = SPair x y 89 | 90 | class TransType f where 91 | transTypeAlg :: Alg f VType 92 | 93 | transType :: (Functor f, TransType f) => Term f -> VType 94 | transType = cata transTypeAlg 95 | 96 | $(derive [liftSum] [''TransType]) 97 | 98 | instance TransType ValueT where 99 | transTypeAlg TInt = VTInt 100 | transTypeAlg TBool = VTBool 101 | transTypeAlg (TPair x y) = VTPair x y -------------------------------------------------------------------------------- /benchmark/Functions.hs: -------------------------------------------------------------------------------- 1 | module Functions 2 | ( module Functions.Comp, 3 | module Functions.Standard ) where 4 | import Functions.Comp 5 | import Functions.Standard 6 | -------------------------------------------------------------------------------- /benchmark/Functions/Comp.hs: -------------------------------------------------------------------------------- 1 | module Functions.Comp 2 | ( module Functions.Comp.Desugar, 3 | module Functions.Comp.Eval, 4 | module Functions.Comp.Inference, 5 | module Functions.Comp.FreeVars ) where 6 | import Functions.Comp.Desugar 7 | import Functions.Comp.Eval 8 | import Functions.Comp.Inference 9 | import Functions.Comp.FreeVars -------------------------------------------------------------------------------- /benchmark/Functions/Comp/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TemplateHaskell, 3 | MultiParamTypeClasses, 4 | FlexibleInstances, 5 | FlexibleContexts, 6 | UndecidableInstances, 7 | TypeOperators, 8 | ScopedTypeVariables, 9 | TypeSynonymInstances, 10 | ConstraintKinds #-} 11 | 12 | module Functions.Comp.Desugar where 13 | 14 | import DataTypes.Comp 15 | import Data.Comp 16 | import Data.Comp.Derive 17 | 18 | -- de-sugar 19 | 20 | class (Functor e, Traversable f) => Desug f e where 21 | desugAlg :: Hom f e 22 | 23 | $(derive [liftSum] [''Desug]) 24 | 25 | desugExpr :: SugarExpr -> Expr 26 | desugExpr = desug 27 | 28 | desugExpr' :: SugarExpr -> Expr 29 | desugExpr' = desug' 30 | 31 | desug :: Desug f e => Term f -> Term e 32 | {-# INLINE desug #-} 33 | desug = appHom desugAlg 34 | 35 | desug' :: Desug f e => Term f -> Term e 36 | {-# INLINE desug' #-} 37 | desug' = appHom' desugAlg 38 | 39 | instance (Value :<: v, Functor v) => Desug Value v where 40 | desugAlg = liftCxt 41 | 42 | instance (Op :<: v, Functor v) => Desug Op v where 43 | desugAlg = liftCxt 44 | 45 | instance (Op :<: v, Value :<: v, Functor v) => Desug Sugar v where 46 | desugAlg (Neg x) = iVInt (-1) `iMult` (Hole x) 47 | desugAlg (Minus x y) = (Hole x) `iPlus` ((iVInt (-1)) `iMult` (Hole y)) 48 | desugAlg (Gt x y) = (Hole y) `iLt` (Hole x) 49 | desugAlg (Or x y) = iNot (iNot (Hole x) `iAnd` iNot (Hole y)) 50 | desugAlg (Impl x y) = iNot ((Hole x) `iAnd` iNot (Hole y)) 51 | 52 | 53 | -- standard algebraic approach 54 | 55 | class Desug2 f g where 56 | desugAlg2 :: Alg f (Term g) 57 | 58 | desugExpr2 :: SugarExpr -> Expr 59 | desugExpr2 = desug2 60 | 61 | desug2 :: (Functor f, Desug2 f g) => Term f -> Term g 62 | desug2 = cata desugAlg2 63 | 64 | instance (Desug2 f1 g, Desug2 f2 g) => Desug2 (f1 :+: f2) g where 65 | desugAlg2 = caseF desugAlg2 desugAlg2 66 | 67 | instance (Value :<: v) => Desug2 Value v where 68 | desugAlg2 = inject 69 | 70 | instance (Op :<: v) => Desug2 Op v where 71 | desugAlg2 = inject 72 | 73 | instance (Op :<: v, Value :<: v, Functor v) => Desug2 Sugar v where 74 | desugAlg2 (Neg x) = iVInt (-1) `iMult` x 75 | desugAlg2 (Minus x y) = x `iPlus` ((iVInt (-1)) `iMult` y) 76 | desugAlg2 (Gt x y) = y `iLt` x 77 | desugAlg2 (Or x y) = iNot (iNot x `iAnd` iNot y) 78 | desugAlg2 (Impl x y) = iNot (x `iAnd` iNot y) 79 | 80 | -------------------------------------------------------------------------------- /benchmark/Functions/Comp/FreeVars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TemplateHaskell, 3 | MultiParamTypeClasses, 4 | FlexibleInstances, 5 | FlexibleContexts, 6 | UndecidableInstances, 7 | TypeOperators, 8 | ScopedTypeVariables, 9 | TypeSynonymInstances, 10 | ConstraintKinds #-} 11 | 12 | module Functions.Comp.FreeVars where 13 | 14 | import DataTypes.Comp 15 | import Data.Comp.Variables 16 | import Data.Comp.Sum 17 | import Data.Comp 18 | import qualified Data.Foldable as F 19 | 20 | -- we interpret integers as variables here 21 | 22 | 23 | instance HasVars Value Int where 24 | isVar (VInt i) = Just i 25 | isVar _ = Nothing 26 | 27 | instance HasVars Op Int where 28 | 29 | instance HasVars Sugar Int where 30 | 31 | contVar :: Int -> SugarExpr -> Bool 32 | contVar = containsVar 33 | 34 | 35 | freeVars :: SugarExpr -> [Int] 36 | freeVars = variableList 37 | 38 | contVar' :: Int -> SugarExpr -> Bool 39 | contVar' i = cata alg 40 | where alg :: SugarSig Bool -> Bool 41 | alg x = case proj x of 42 | Just (VInt j) -> i == j 43 | _ -> F.foldl (||) False x 44 | 45 | contVarGen :: Int -> SugarExpr -> Bool 46 | contVarGen i e = elem i [ j | VInt j <- subterms' e] 47 | 48 | freeVars' :: SugarExpr -> [Int] 49 | freeVars' = cata alg 50 | where alg :: SugarSig [Int] -> [Int] 51 | alg x = case proj x of 52 | Just (VInt j) -> [ j ] 53 | _ -> F.foldl (++) [] x 54 | 55 | 56 | freeVarsGen :: SugarExpr -> [Int] 57 | freeVarsGen e = [ j | VInt j <- subterms' e] 58 | -------------------------------------------------------------------------------- /benchmark/Functions/Comp/HOAS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TemplateHaskell, 3 | MultiParamTypeClasses, 4 | FlexibleInstances, 5 | FlexibleContexts, 6 | UndecidableInstances, 7 | TypeOperators, 8 | ScopedTypeVariables, 9 | TypeSynonymInstances #-} 10 | 11 | module Functions.Comp.Desugar where 12 | 13 | import DataTypes.Comp 14 | import Data.Comp.ExpFunctor 15 | import Data.Comp 16 | import Data.Foldable 17 | import Prelude hiding (foldr) 18 | 19 | ex1 :: HOASExpr 20 | ex1 = iLam (\x -> case project x of 21 | Just (VInt _) -> x 22 | _ -> x `iPlus` x) 23 | ex2 :: HOASExpr 24 | ex2 = iLam (\x -> case x of 25 | Term t -> case proj t of 26 | Just (VInt _) -> x 27 | _ -> x `iPlus` x) 28 | 29 | 30 | class Vars f where 31 | varsAlg :: Alg f Int 32 | 33 | instance (Vars f, Vars g) => Vars (g :+: f) where 34 | varsAlg (Inl v) = varsAlg v 35 | varsAlg (Inr v) = varsAlg v 36 | 37 | instance Vars Lam where 38 | varsAlg (Lam f) = f 1 39 | 40 | instance Vars App where 41 | varsAlg = foldr (+) 0 42 | 43 | instance Vars Value where 44 | varsAlg = foldr (+) 0 45 | 46 | instance Vars Op where 47 | varsAlg = foldr (+) 0 48 | 49 | 50 | instance Vars Sugar where 51 | varsAlg = foldr (+) 0 52 | 53 | vars :: (ExpFunctor f, Vars f) => Term f -> Int 54 | vars = cataE varsAlg 55 | -------------------------------------------------------------------------------- /benchmark/Functions/Standard.hs: -------------------------------------------------------------------------------- 1 | module Functions.Standard 2 | ( module Functions.Standard.Desugar, 3 | module Functions.Standard.Eval, 4 | module Functions.Standard.Inference, 5 | module Functions.Standard.FreeVars) where 6 | import Functions.Standard.Desugar 7 | import Functions.Standard.Eval 8 | import Functions.Standard.Inference 9 | import Functions.Standard.FreeVars -------------------------------------------------------------------------------- /benchmark/Functions/Standard/Desugar.hs: -------------------------------------------------------------------------------- 1 | module Functions.Standard.Desugar where 2 | 3 | import DataTypes.Standard 4 | 5 | -- de-sugar 6 | 7 | desug :: PExpr -> OExpr 8 | desug (PInt i) = OInt i 9 | desug (PBool b) = OBool b 10 | desug (PPair x y) = OPair (desug x) (desug y) 11 | desug (PPlus x y) = OPlus (desug x) (desug y) 12 | desug (PMult x y) = OMult (desug x) (desug y) 13 | desug (PIf b x y) = OIf (desug b) (desug x) (desug y) 14 | desug (PEq x y) = OEq (desug x) (desug y) 15 | desug (PLt x y) = OLt (desug x) (desug y) 16 | desug (PAnd x y) = OAnd (desug x) (desug y) 17 | desug (PNot x) = ONot (desug x) 18 | desug (PProj p x) = OProj p (desug x) 19 | desug (PNeg x) = OInt (-1) `OMult` (desug x) 20 | desug (PMinus x y) = (desug x) `OPlus` ((OInt (-1)) `OMult` (desug y)) 21 | desug (PGt x y) = (desug y) `OLt` (desug x) 22 | desug (POr x y) = ONot (ONot (desug x) `OAnd` ONot (desug y)) 23 | desug (PImpl x y) = ONot ((desug x) `OAnd` ONot (desug y)) 24 | 25 | 26 | desug' :: PExpr -> PExpr 27 | desug' e@(PInt _) = e 28 | desug' e@(PBool _) = e 29 | desug' (PPair x y) = PPair (desug' x) (desug' y) 30 | desug' (PPlus x y) = PPlus (desug' x) (desug' y) 31 | desug' (PMult x y) = PMult (desug' x) (desug' y) 32 | desug' (PIf b x y) = PIf (desug' b) (desug' x) (desug' y) 33 | desug' (PEq x y) = PEq (desug' x) (desug' y) 34 | desug' (PLt x y) = PLt (desug' x) (desug' y) 35 | desug' (PAnd x y) = PAnd (desug' x) (desug' y) 36 | desug' (PNot x) = PNot (desug' x) 37 | desug' (PProj p x) = PProj p (desug' x) 38 | desug' (PNeg x) = PInt (-1) `PMult` (desug' x) 39 | desug' (PMinus x y) = (desug' x) `PPlus` ((PInt (-1)) `PMult` (desug' y)) 40 | desug' (PGt x y) = (desug' y) `PLt` (desug' x) 41 | desug' (POr x y) = PNot (PNot (desug' x) `PAnd` PNot (desug' y)) 42 | desug' (PImpl x y) = PNot ((desug' x) `PAnd` PNot (desug' y)) -------------------------------------------------------------------------------- /benchmark/Functions/Standard/FreeVars.hs: -------------------------------------------------------------------------------- 1 | module Functions.Standard.FreeVars where 2 | 3 | import DataTypes.Standard 4 | import Data.Generics.Uniplate.Direct 5 | 6 | instance Uniplate PExpr where 7 | uniplate (PInt x) = plate PInt |- x 8 | uniplate (PBool x) = plate PBool |- x 9 | uniplate (PPair x y) = plate PPair |* x |* y 10 | uniplate (PMult x y) = plate PMult |* x |* y 11 | uniplate (PPlus x y) = plate PPlus |* x |* y 12 | uniplate (PIf x y z) = plate PIf |* x |* y |* z 13 | uniplate (PEq x y) = plate PEq |* x |* y 14 | uniplate (PLt x y) = plate PLt |* x |* y 15 | uniplate (PAnd x y) = plate PAnd |* x |* y 16 | uniplate (PNot x) = plate PNot |* x 17 | uniplate (PProj x y) = plate PProj |- x |* y 18 | uniplate (PNeg x) = plate PNeg |* x 19 | uniplate (PMinus x y) = plate PMinus |* x |* y 20 | uniplate (PGt x y) = plate PGt |* x |* y 21 | uniplate (POr x y) = plate POr |* x |* y 22 | uniplate (PImpl x y) = plate PImpl |* x |* y 23 | 24 | 25 | contVar :: Int -> PExpr -> Bool 26 | contVar v e = 27 | case e of 28 | PInt i -> i == v 29 | PBool{} -> False 30 | PPair x y -> re x || re y 31 | PPlus x y -> re x || re y 32 | PMult x y -> re x || re y 33 | PIf x y z -> re x || re y || re z 34 | PEq x y -> re x || re y 35 | PLt x y -> re x || re y 36 | PAnd x y -> re x || re y 37 | PNot x -> re x 38 | PProj _ x -> re x 39 | PNeg x -> re x 40 | PMinus x y -> re x || re y 41 | PGt x y -> re x || re y 42 | POr x y -> re x || re y 43 | PImpl x y -> re x || re y 44 | where re = contVar v 45 | 46 | freeVars :: PExpr -> [Int] 47 | freeVars e = 48 | case e of 49 | PInt i -> [i] 50 | PBool{} -> [] 51 | PPair x y -> re2 x y 52 | PPlus x y -> re2 x y 53 | PMult x y -> re2 x y 54 | PIf x y z -> re3 x y z 55 | PEq x y -> re2 x y 56 | PLt x y -> re2 x y 57 | PAnd x y -> re2 x y 58 | PNot x -> re x 59 | PProj _ x -> re x 60 | PNeg x -> re x 61 | PMinus x y -> re2 x y 62 | PGt x y -> re2 x y 63 | POr x y -> re2 x y 64 | PImpl x y -> re2 x y 65 | where re = freeVars 66 | re2 x y = re x ++ re y 67 | re3 x y z = re x ++ re y ++ re z 68 | 69 | contVarGen :: Int -> PExpr -> Bool 70 | contVarGen v e = elem v [ j | (PInt j) <- universe e] 71 | 72 | freeVarsGen :: PExpr -> [Int] 73 | freeVarsGen e = [ j | (PInt j) <- universe e] 74 | -------------------------------------------------------------------------------- /benchmark/Multi/DataTypes/Comp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TemplateHaskell, 3 | FlexibleInstances, 4 | FlexibleContexts, 5 | TypeOperators, 6 | GADTs, 7 | KindSignatures, 8 | IncoherentInstances #-} 9 | 10 | -- base values 11 | 12 | module Multi.DataTypes.Comp where 13 | 14 | import Data.Comp.Derive 15 | import Data.Comp.Multi 16 | 17 | type ValueExpr = HTerm Value 18 | type ExprSig = Value :++: Op 19 | type Expr = HTerm ExprSig 20 | type SugarSig = Value :++: Op :++: Sugar 21 | type SugarExpr = HTerm SugarSig 22 | type BaseType = HTerm ValueT 23 | 24 | data ValueT e t = TInt 25 | | TBool 26 | | TPair (e t) (e t) 27 | deriving (Eq) 28 | 29 | data Value e t where 30 | VInt :: Int -> Value e Int 31 | VBool :: Bool -> Value e Bool 32 | VPair :: e s -> e t -> Value e (s,t) 33 | 34 | data Op e t where 35 | Plus :: e Int -> e Int -> Op e Int 36 | Mult :: e Int -> e Int -> Op e Int 37 | If :: e Bool -> e t -> e t -> Op e t 38 | Lt :: e Int -> e Int -> Op e Bool 39 | Eq :: e Int -> e Int -> Op e Bool 40 | And :: e Bool -> e Bool -> Op e Bool 41 | Not :: e Bool -> Op e Bool 42 | ProjLeft :: e (s,t) -> Op e s 43 | ProjRight :: e (s,t) -> Op e t 44 | 45 | data Sugar e t where 46 | Neg :: e Int -> Sugar e Int 47 | Minus :: e Int -> e Int -> Sugar e Int 48 | Gt :: e Int -> e Int -> Sugar e Bool 49 | Or :: e Bool -> e Bool -> Sugar e Bool 50 | Impl :: e Bool -> e Bool -> Sugar e Bool 51 | 52 | $(derive 53 | [makeHFunctor, makeHFoldable, makeHTraversable, makeHEqF, smartHConstructors] 54 | [''ValueT, ''Value, ''Op, ''Sugar]) 55 | 56 | 57 | showBinOp :: String -> String -> String -> String 58 | showBinOp op x y = "("++ x ++ op ++ y ++ ")" 59 | 60 | instance HShowF ValueT where 61 | hshowF' TInt = "Int" 62 | hshowF' TBool = "Bool" 63 | hshowF' (TPair (K x) (K y)) = showBinOp "," x y 64 | 65 | instance HShowF Value where 66 | hshowF' (VInt i) = show i 67 | hshowF' (VBool b) = show b 68 | hshowF' (VPair (K x) (K y)) = showBinOp "," x y 69 | 70 | instance HShowF Op where 71 | hshowF' (Plus (K x) (K y)) = showBinOp "+" x y 72 | hshowF' (Mult (K x) (K y)) = showBinOp "*" x y 73 | hshowF' (If (K b) (K x) (K y)) = "if " ++ b ++ " then " ++ x ++ " else " ++ y ++ " fi" 74 | hshowF' (Eq (K x) (K y)) = showBinOp "==" x y 75 | hshowF' (Lt (K x) (K y)) = showBinOp "<" x y 76 | hshowF' (And (K x) (K y)) = showBinOp "&&" x y 77 | hshowF' (Not (K x)) = "~" ++ x 78 | hshowF' (ProjLeft (K x)) = x ++ "!0" 79 | hshowF' (ProjRight (K x)) = x ++ "!1" -------------------------------------------------------------------------------- /benchmark/Multi/Functions/Comp/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TemplateHaskell, 3 | MultiParamTypeClasses, 4 | FlexibleInstances, 5 | FlexibleContexts, 6 | UndecidableInstances, 7 | TypeOperators, 8 | ScopedTypeVariables, 9 | TypeSynonymInstances, 10 | GADTs#-} 11 | 12 | module Multi.Functions.Comp.Desugar where 13 | 14 | import Multi.DataTypes.Comp 15 | import Data.Comp.Multi 16 | 17 | -- de-sugar 18 | 19 | class (HFunctor e, HFunctor f) => Desugar f e where 20 | desugarAlg :: HHom f e 21 | desugarAlg = desugarAlg' . hfmap HHole 22 | desugarAlg' :: HAlg f (HContext e a) 23 | desugarAlg' x = appHCxt $ desugarAlg x 24 | 25 | desugarExpr :: SugarExpr :-> Expr 26 | desugarExpr = desugar 27 | 28 | desugar :: Desugar f e => HTerm f :-> HTerm e 29 | desugar = appHHom desugarAlg 30 | 31 | instance (Desugar f e, Desugar g e) => Desugar (g :++: f) e where 32 | desugarAlg (HInl v) = desugarAlg v 33 | desugarAlg (HInr v) = desugarAlg v 34 | 35 | instance (Value :<<: v, HFunctor v) => Desugar Value v where 36 | desugarAlg = liftHCxt 37 | 38 | instance (Op :<<: v, HFunctor v) => Desugar Op v where 39 | desugarAlg = liftHCxt 40 | 41 | instance (Op :<<: v, Value :<<: v, HFunctor v) => Desugar Sugar v where 42 | desugarAlg' (Neg x) = iVInt (-1) `iMult` x 43 | desugarAlg' (Minus x y) = x `iPlus` ((iVInt (-1)) `iMult` y) 44 | desugarAlg' (Gt x y) = y `iLt` x 45 | desugarAlg' (Or x y) = iNot (iNot x `iAnd` iNot y) 46 | desugarAlg' (Impl x y) = iNot (x `iAnd` iNot y) -------------------------------------------------------------------------------- /benchmark/Multi/Functions/Comp/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | GADTs, 3 | TemplateHaskell, 4 | MultiParamTypeClasses, 5 | FlexibleInstances, 6 | FlexibleContexts, 7 | UndecidableInstances, 8 | TypeOperators, 9 | ScopedTypeVariables, 10 | TypeSynonymInstances#-} 11 | 12 | module Multi.Functions.Comp.Eval where 13 | 14 | import Multi.DataTypes.Comp 15 | import Multi.Functions.Comp.Desugar 16 | import Data.Comp.Multi 17 | import Data.Comp.Multi.HEquality 18 | 19 | -- evaluation 20 | 21 | class Eval e v where 22 | evalAlg :: Alg e (Term v) 23 | 24 | eval :: (HFunctor e, Eval e v) => Term e :-> (Term v) 25 | eval = cata evalAlg 26 | 27 | instance (Eval f v, Eval g v) => Eval (f :++: g) v where 28 | evalAlg (HInl v) = evalAlg v 29 | evalAlg (HInr v) = evalAlg v 30 | 31 | instance (Value :<<: v) => Eval Value v where 32 | evalAlg = inject 33 | 34 | 35 | getInt :: (Value :<<: v) => Term v Int -> Int 36 | getInt t = case project t of 37 | Just (VInt x) -> x 38 | Nothing -> undefined 39 | getBool :: (Value :<<: v) => Term v Bool -> Bool 40 | getBool t = case project t of 41 | Just (VBool x) -> x 42 | Nothing -> undefined 43 | 44 | getPair :: (Value :<<: v) => Term v (s,t) -> ((Term v s), (Term v t)) 45 | getPair t = case project t of 46 | Just (VPair x y) -> (x, y) 47 | Nothing -> undefined 48 | 49 | 50 | instance (Value :<<: v, HEqF v) => Eval Op v where 51 | evalAlg (Plus x y) = iVInt $ getInt x + getInt y 52 | evalAlg (Mult x y) = iVInt $ getInt x * getInt y 53 | evalAlg (If b x y) = if getBool b then x else y 54 | evalAlg (Eq x y) = iVBool $ x == y 55 | evalAlg (Lt x y) = iVBool $ getInt x < getInt y 56 | evalAlg (And x y) = iVBool $ getBool x && getBool y 57 | evalAlg (Not x) = iVBool $ not $ getBool x 58 | evalAlg (ProjLeft x) = fst $ getPair x 59 | evalAlg (ProjRight x) = snd $ getPair x 60 | 61 | instance (Value :<<: v) => Eval Sugar v where 62 | evalAlg (Neg x) = iVInt $ negate $ getInt x 63 | evalAlg (Minus x y) = iVInt $ getInt x - getInt y 64 | evalAlg (Gt x y) = iVBool $ getInt x > getInt y 65 | evalAlg (Or x y) = iVBool $ getBool x || getBool y 66 | evalAlg (Impl x y) = iVBool $ not (getBool x) || getBool y 67 | 68 | desugarEval :: SugarExpr :-> ValueExpr 69 | desugarEval = eval . (desugar :: SugarExpr :-> Expr) 70 | 71 | evalSugar :: SugarExpr :-> ValueExpr 72 | evalSugar = eval 73 | 74 | desugarEvalAlg :: Alg SugarSig ValueExpr 75 | desugarEvalAlg = evalAlg `compAlg` (desugarAlg :: Hom SugarSig ExprSig) 76 | 77 | desugarEval' :: SugarExpr :-> ValueExpr 78 | desugarEval' e = cata desugarEvalAlg e -------------------------------------------------------------------------------- /benchmark/Param/DataTypes/Standard.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, TemplateHaskell, DeriveDataTypeable, 2 | FlexibleInstances #-} 3 | module Param.DataTypes.Standard 4 | ( 5 | module Param.DataTypes.Standard, 6 | module Param.DataTypes 7 | ) where 8 | 9 | import Param.DataTypes 10 | import Data.Derive.NFData 11 | import Data.DeriveTH 12 | import Data.Data 13 | import Control.DeepSeq 14 | 15 | -- base values 16 | 17 | data VType = VTInt 18 | | VTBool 19 | | VTPair VType VType 20 | | VTFun VType VType 21 | deriving (Eq,Typeable,Data) 22 | 23 | data SExpr = SInt Int 24 | | SBool Bool 25 | | SPair SExpr SExpr 26 | | SFun (SExpr -> SExpr) 27 | deriving (Typeable,Data) 28 | 29 | data SProj = SProjLeft | SProjRight 30 | deriving (Eq,Typeable,Data) 31 | 32 | data OExpr = OInt Int 33 | | OBool Bool 34 | | OPair OExpr OExpr 35 | | OPlus OExpr OExpr 36 | | OMult OExpr OExpr 37 | | OIf OExpr OExpr OExpr 38 | | OEq OExpr OExpr 39 | | OLt OExpr OExpr 40 | | OAnd OExpr OExpr 41 | | ONot OExpr 42 | | OProj SProj OExpr 43 | | OLam (OExpr -> OExpr) 44 | | OApp OExpr OExpr 45 | deriving (Typeable,Data) 46 | 47 | data PExpr = PInt Int 48 | | PBool Bool 49 | | PPair PExpr PExpr 50 | | PPlus PExpr PExpr 51 | | PMult PExpr PExpr 52 | | PIf PExpr PExpr PExpr 53 | | PEq PExpr PExpr 54 | | PLt PExpr PExpr 55 | | PAnd PExpr PExpr 56 | | PNot PExpr 57 | | PProj SProj PExpr 58 | | PNeg PExpr 59 | | PMinus PExpr PExpr 60 | | PGt PExpr PExpr 61 | | POr PExpr PExpr 62 | | PImpl PExpr PExpr 63 | | PLam (PExpr -> PExpr) 64 | | PApp PExpr PExpr 65 | | PLet PExpr (PExpr -> PExpr) 66 | deriving (Typeable,Data) 67 | 68 | instance NFData (SExpr -> SExpr) where 69 | rnf f = f `seq` () 70 | 71 | instance NFData (OExpr -> OExpr) where 72 | rnf f = f `seq` () 73 | 74 | instance NFData (PExpr -> PExpr) where 75 | rnf f = f `seq` () 76 | 77 | $(derives [makeNFData] [''SProj,''SExpr,''OExpr,''PExpr,''VType]) -------------------------------------------------------------------------------- /benchmark/Param/DataTypes/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances, 2 | FlexibleContexts, UndecidableInstances, TypeOperators, ScopedTypeVariables, 3 | TypeSynonymInstances #-} 4 | 5 | module Param.DataTypes.Transform where 6 | 7 | import Data.Comp.Param 8 | import Param.DataTypes.Standard as S 9 | import Param.DataTypes.Comp 10 | 11 | class TransSugar f where 12 | transSugarAlg :: Alg f PExpr 13 | 14 | transSugar :: (Difunctor f, TransSugar f) => Term f -> PExpr 15 | transSugar = cata transSugarAlg 16 | 17 | instance (TransSugar f, TransSugar g) => TransSugar (f :+: g) where 18 | transSugarAlg (Inl v) = transSugarAlg v 19 | transSugarAlg (Inr v) = transSugarAlg v 20 | 21 | instance TransSugar Value where 22 | transSugarAlg (VInt i) = PInt i 23 | transSugarAlg (VBool b) = PBool b 24 | transSugarAlg (VPair x y) = PPair x y 25 | 26 | instance TransSugar Op where 27 | transSugarAlg (Plus x y) = PPlus x y 28 | transSugarAlg (Mult x y) = PMult x y 29 | transSugarAlg (If b x y) = PIf b x y 30 | transSugarAlg (Lt x y) = PLt x y 31 | transSugarAlg (And x y) = PAnd x y 32 | transSugarAlg (Not x) = PNot x 33 | transSugarAlg (Proj p x) = PProj (ptrans p) x 34 | where ptrans ProjLeft = SProjLeft 35 | ptrans ProjRight = SProjRight 36 | transSugarAlg (Eq x y) = PEq x y 37 | 38 | instance TransSugar Lam where 39 | transSugarAlg (Lam f) = PLam f 40 | transSugarAlg (App x y) = PApp x y 41 | 42 | instance TransSugar Sugar where 43 | transSugarAlg (Neg x) = PNeg x 44 | transSugarAlg (Minus x y) = PMinus x y 45 | transSugarAlg (Gt x y) = PGt x y 46 | transSugarAlg (Or x y) = POr x y 47 | transSugarAlg (Impl x y) = PImpl x y 48 | 49 | instance TransSugar SugarLet where 50 | transSugarAlg (Let x y) = PLet x y 51 | 52 | 53 | class TransCore f where 54 | transCoreAlg :: Alg f OExpr 55 | 56 | transCore :: (Difunctor f, TransCore f) => Term f -> OExpr 57 | transCore = cata transCoreAlg 58 | 59 | 60 | instance (TransCore f, TransCore g) => TransCore (f :+: g) where 61 | transCoreAlg (Inl v) = transCoreAlg v 62 | transCoreAlg (Inr v) = transCoreAlg v 63 | 64 | instance TransCore Value where 65 | transCoreAlg (VInt i) = OInt i 66 | transCoreAlg (VBool b) = OBool b 67 | transCoreAlg (VPair x y) = OPair x y 68 | 69 | instance TransCore Op where 70 | transCoreAlg (Plus x y) = OPlus x y 71 | transCoreAlg (Mult x y) = OMult x y 72 | transCoreAlg (If b x y) = OIf b x y 73 | transCoreAlg (Lt x y) = OLt x y 74 | transCoreAlg (And x y) = OAnd x y 75 | transCoreAlg (Not x) = ONot x 76 | transCoreAlg (Proj p x) = OProj (ptrans p) x 77 | where ptrans ProjLeft = SProjLeft 78 | ptrans ProjRight = SProjRight 79 | transCoreAlg (Eq x y) = OEq x y 80 | 81 | instance TransCore Lam where 82 | transCoreAlg (Lam f) = OLam f 83 | transCoreAlg (App x y) = OApp x y 84 | 85 | class TransVal f where 86 | transValAlg :: Alg f SExpr 87 | 88 | transVal :: (Difunctor f, TransVal f) => Term f -> SExpr 89 | transVal = cata transValAlg 90 | 91 | 92 | instance (TransVal f, TransVal g) => TransVal (f :+: g) where 93 | transValAlg (Inl v) = transValAlg v 94 | transValAlg (Inr v) = transValAlg v 95 | 96 | instance TransVal Value where 97 | transValAlg (VInt i) = SInt i 98 | transValAlg (VBool b) = SBool b 99 | transValAlg (VPair x y) = SPair x y 100 | 101 | instance TransVal Fun where 102 | transValAlg (Fun f) = SFun f 103 | 104 | class TransType f where 105 | transTypeAlg :: Alg f VType 106 | 107 | transType :: (Difunctor f, TransType f) => Term f -> VType 108 | transType = cata transTypeAlg 109 | 110 | 111 | instance (TransType f, TransType g) => TransType (f :+: g) where 112 | transTypeAlg (Inl v) = transTypeAlg v 113 | transTypeAlg (Inr v) = transTypeAlg v 114 | 115 | instance TransType ValueT where 116 | transTypeAlg TInt = VTInt 117 | transTypeAlg TBool = VTBool 118 | transTypeAlg (TPair x y) = VTPair x y 119 | transTypeAlg (TFun x y) = VTFun x y -------------------------------------------------------------------------------- /benchmark/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Functions.Comp as A 4 | import qualified Functions.Standard as S 5 | import DataTypes.Comp 6 | import DataTypes.Transform 7 | import Test.QuickCheck 8 | import Data.List 9 | 10 | main = mapM_ (quickCheckWith stdArgs{maxSize=10}) allProp 11 | 12 | allProp = map forAllTyped [prop_desug, prop_desugAlg, prop_desugType, prop_desugType', prop_typeSugar, prop_desugType2, prop_desugType2', prop_typeSugar2, prop_desugEval, prop_desugEval', prop_evalSugar, prop_evalSugar, prop_evalDirect, prop_desugEval2, prop_desugEval2', prop_evalSugar2, prop_evalDirect2, prop_freeVars, prop_freeVars', prop_freeVarsGen, prop_freeVarsGenS] 13 | ++ map forAllTyped [prop_contVar, prop_contVar', prop_contVarGen, prop_contVarGenS] 14 | 15 | prop_desug x = transCore (A.desugExpr x) == S.desug (transSugar x) 16 | 17 | prop_desugAlg x = transCore (A.desugExpr2 x) == S.desug (transSugar x) 18 | 19 | prop_desugType x = fmap transType (A.desugType x) == S.desugType (transSugar x) 20 | 21 | prop_desugType' x = fmap transType (A.desugType' x) == S.desugType (transSugar x) 22 | 23 | prop_typeSugar x = fmap transType (A.typeSugar x) == S.typeSugar (transSugar x) 24 | 25 | prop_desugType2 x = transType (A.desugType2 x) == S.desugType2 (transSugar x) 26 | 27 | prop_desugType2' x = transType (A.desugType2' x) == S.desugType2 (transSugar x) 28 | 29 | prop_typeSugar2 x = transType (A.typeSugar2 x) == S.typeSugar2 (transSugar x) 30 | 31 | prop_desugEval x = fmap transVal (A.desugEval x) == S.desugEval (transSugar x) 32 | 33 | prop_desugEval' x = fmap transVal (A.desugEval' x) == S.desugEval (transSugar x) 34 | 35 | prop_evalSugar x = fmap transVal (A.evalSugar x) == S.evalSugar (transSugar x) 36 | 37 | prop_evalDirect x = fmap transVal (A.evalDirect x) == S.evalSugar (transSugar x) 38 | 39 | prop_desugEval2 x = transVal (A.desugEval2 x) == S.desugEval2 (transSugar x) 40 | 41 | prop_desugEval2' x = transVal (A.desugEval2' x) == S.desugEval2 (transSugar x) 42 | 43 | prop_evalSugar2 x = transVal (A.evalSugar2 x) == S.evalSugar2 (transSugar x) 44 | 45 | prop_evalDirect2 x = transVal (A.evalDirect2 x) == S.evalSugar2 (transSugar x) 46 | 47 | prop_contVar x v = A.contVar v x == S.contVar v (transSugar x) 48 | 49 | prop_contVar' x v = A.contVar' v x == S.contVar v (transSugar x) 50 | 51 | prop_contVarGen x v = A.contVarGen v x == S.contVar v (transSugar x) 52 | 53 | prop_contVarGenS x v = S.contVarGen v (transSugar x) == S.contVar v (transSugar x) 54 | 55 | prop_freeVars x = A.freeVars x == S.freeVars (transSugar x) 56 | 57 | prop_freeVars' x = A.freeVars' x == S.freeVars (transSugar x) 58 | 59 | prop_freeVarsGen x = sort (A.freeVarsGen x) == sort (S.freeVars (transSugar x)) 60 | 61 | prop_freeVarsGenS x = S.freeVarsGen (transSugar x) == S.freeVars (transSugar x) -------------------------------------------------------------------------------- /benchmark/Transformations.hs: -------------------------------------------------------------------------------- 1 | module Transformations where 2 | 3 | import DataTypes 4 | import Data.Comp 5 | 6 | 7 | toBaseExp :: Term Value -> BaseExp 8 | toBaseExp = algHom toBaseExpAlg 9 | where toBaseExpAlg (VInt i) = BInt i 10 | toBaseExpAlg (VBool b) = BBool b 11 | toBaseExpAlg (VString s) = BString s 12 | toBaseExpAlg (VDateTime d) = BDateTime d 13 | toBaseExpAlg (VDuration d) = BDuration d 14 | toBaseExpAlg (VDouble d) = BDouble d 15 | toBaseExpAlg (VRecord r) = BRecord r 16 | toBaseExpAlg (VList l) = BList l 17 | 18 | toRepExp :: Term Value -> RepExp 19 | toRepExp = algHom toRepExpAlg 20 | where toRepExpAlg (VInt i) = RInt i 21 | toRepExpAlg (VBool b) = RBool b 22 | toRepExpAlg (VString s) = RString s 23 | toRepExpAlg (VDateTime d) = RDateTime d 24 | toRepExpAlg (VDuration d) = RDuration d 25 | toRepExpAlg (VDouble d) = RDouble d 26 | toRepExpAlg (VRecord r) = RRecord r 27 | toRepExpAlg (VList l) = RList l 28 | -------------------------------------------------------------------------------- /examples/Examples/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Examples.Common 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- Common definitions used in examples. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Examples.Common where 18 | 19 | import Data.Comp 20 | import Data.Comp.Derive 21 | import Data.Comp.Show () 22 | import Data.Comp.Equality () 23 | 24 | -- Signature for values and operators 25 | data Value a = Const Int | Pair a a 26 | deriving Functor 27 | data Op a = Add a a | Mult a a | Fst a | Snd a 28 | deriving Functor 29 | 30 | -- Signature for the simple expression language 31 | type Sig = Op :+: Value 32 | 33 | -- Derive boilerplate code using Template Haskell 34 | $(derive [makeTraversable, makeFoldable, 35 | makeEqF, makeShowF, smartConstructors, smartAConstructors] 36 | [''Value, ''Op]) 37 | -------------------------------------------------------------------------------- /examples/Examples/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, 3 | ConstraintKinds #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | -------------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Examples.Desugar 8 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 9 | -- License : BSD3 10 | -- Maintainer : Tom Hvitved 11 | -- Stability : experimental 12 | -- Portability : non-portable (GHC Extensions) 13 | -- 14 | -- Desugaring 15 | -- 16 | -- The example illustrates how to compose a term homomorphism and an algebra, 17 | -- exemplified via a desugaring term homomorphism and an evaluation algebra. 18 | -- The example also illustrates how to lift a term homomorphism to annotations, 19 | -- exemplified via a desugaring term homomorphism lifted to terms annotated with 20 | -- source position information. 21 | -- 22 | -------------------------------------------------------------------------------- 23 | 24 | module Examples.Desugar where 25 | 26 | import Data.Comp 27 | import Data.Comp.Show () 28 | import Data.Comp.Derive 29 | import Data.Comp.Desugar 30 | import Examples.Common 31 | import Examples.Eval 32 | 33 | -- Signature for syntactic sugar 34 | data Sugar a = Neg a | Swap a 35 | deriving Functor 36 | 37 | -- Source position information (line number, column number) 38 | data Pos = Pos Int Int 39 | deriving (Show, Eq) 40 | 41 | -- Signature for the simple expression language, extended with syntactic sugar 42 | type Sig' = Sugar :+: Op :+: Value 43 | 44 | -- Signature for the simple expression language with annotations 45 | type SigP = Op :&: Pos :+: Value :&: Pos 46 | 47 | -- Signature for the simple expression language, extended with syntactic sugar, 48 | -- with annotations 49 | type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos 50 | 51 | -- Derive boilerplate code using Template Haskell 52 | $(derive [makeTraversable, makeFoldable, 53 | makeEqF, makeShowF, makeOrdF, smartConstructors, smartAConstructors] 54 | [''Sugar]) 55 | 56 | instance (Op :<: f, Value :<: f, Functor f) => Desugar Sugar f where 57 | desugHom' (Neg x) = iConst (-1) `iMult` x 58 | desugHom' (Swap x) = iSnd x `iPair` iFst x 59 | 60 | evalDesug :: Term Sig' -> Term Value 61 | evalDesug = eval . (desugar :: Term Sig' -> Term Sig) 62 | 63 | -- Example: evalEx = iPair (iConst 2) (iConst 1) 64 | evalEx :: Term Value 65 | evalEx = evalDesug $ iSwap $ iPair (iConst 1) (iConst 2) 66 | 67 | -- Lift desugaring to terms annotated with source positions 68 | desugP :: Term SigP' -> Term SigP 69 | desugP = appHom (propAnn desugHom) 70 | 71 | -- Example: desugPEx = iAPair (Pos 1 0) 72 | -- (iASnd (Pos 1 0) (iAPair (Pos 1 1) 73 | -- (iAConst (Pos 1 2) 1) 74 | -- (iAConst (Pos 1 3) 2))) 75 | -- (iAFst (Pos 1 0) (iAPair (Pos 1 1) 76 | -- (iAConst (Pos 1 2) 1) 77 | -- (iAConst (Pos 1 3) 2))) 78 | desugPEx :: Term SigP 79 | desugPEx = desugP $ iASwap (Pos 1 0) (iAPair (Pos 1 1) (iAConst (Pos 1 2) 1) 80 | (iAConst (Pos 1 3) 2)) 81 | -------------------------------------------------------------------------------- /examples/Examples/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, 3 | ConstraintKinds #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Examples.Eval 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- Expression Evaluation 14 | -- 15 | -- The example illustrates how to use compositional data types to implement 16 | -- a small expression language, with a sub language of values, and an evaluation 17 | -- function mapping expressions to values. 18 | -- 19 | -------------------------------------------------------------------------------- 20 | 21 | module Examples.Eval where 22 | 23 | import Data.Comp 24 | import Data.Comp.Show () 25 | import Data.Comp.Derive 26 | import Examples.Common 27 | 28 | -- Term evaluation algebra 29 | class Eval f v where 30 | evalAlg :: Alg f (Term v) 31 | 32 | $(derive [liftSum] [''Eval]) 33 | 34 | -- Lift the evaluation algebra to a catamorphism 35 | eval :: (Functor f, Eval f v) => Term f -> Term v 36 | eval = cata evalAlg 37 | 38 | instance {-# OVERLAPPABLE #-} (f :<: v) => Eval f v where 39 | evalAlg = inject -- default instance 40 | 41 | instance {-# OVERLAPPABLE #-} (Value :<: v) => Eval Op v where 42 | evalAlg (Add x y) = iConst $ projC x + projC y 43 | evalAlg (Mult x y) = iConst $ projC x * projC y 44 | evalAlg (Fst x) = fst $ projP x 45 | evalAlg (Snd x) = snd $ projP x 46 | 47 | projC :: (Value :<: v) => Term v -> Int 48 | projC v = case project v of Just (Const n) -> n 49 | 50 | projP :: (Value :<: v) => Term v -> (Term v, Term v) 51 | projP v = case project v of Just (Pair x y) -> (x,y) 52 | 53 | -- Example: evalEx = iConst 5 54 | evalEx :: Term Value 55 | evalEx = eval (iConst 1 `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig) 56 | -------------------------------------------------------------------------------- /examples/Examples/EvalM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, 3 | ConstraintKinds #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Examples.EvalM 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- Monadic Expression Evaluation 14 | -- 15 | -- The example illustrates how to use compositional data types to implement 16 | -- a small expression language, with a sub language of values, and a monadic 17 | -- evaluation function mapping expressions to values. 18 | -- 19 | -------------------------------------------------------------------------------- 20 | 21 | module Examples.EvalM where 22 | 23 | import Data.Comp 24 | import Data.Comp.Derive 25 | import Control.Monad (liftM) 26 | import Examples.Common 27 | 28 | -- Monadic term evaluation algebra 29 | class EvalM f v where 30 | evalAlgM :: AlgM Maybe f (Term v) 31 | 32 | $(derive [liftSum] [''EvalM]) 33 | 34 | -- Lift the monadic evaluation algebra to a monadic catamorphism 35 | evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v) 36 | evalM = cataM evalAlgM 37 | 38 | instance {-# OVERLAPPABLE #-} (f :<: v) => EvalM f v where 39 | evalAlgM = return . inject -- default instance 40 | 41 | instance {-# OVERLAPPABLE #-} (Value :<: v) => EvalM Op v where 42 | evalAlgM (Add x y) = do n1 <- projC x 43 | n2 <- projC y 44 | return $ iConst $ n1 + n2 45 | evalAlgM (Mult x y) = do n1 <- projC x 46 | n2 <- projC y 47 | return $ iConst $ n1 * n2 48 | evalAlgM (Fst v) = liftM fst $ projP v 49 | evalAlgM (Snd v) = liftM snd $ projP v 50 | 51 | projC :: (Value :<: v) => Term v -> Maybe Int 52 | projC v = case project v of 53 | Just (Const n) -> return n 54 | _ -> Nothing 55 | 56 | projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v) 57 | projP v = case project v of 58 | Just (Pair x y) -> return (x,y) 59 | _ -> Nothing 60 | 61 | -- Example: evalMEx = Just (iConst 5) 62 | evalMEx :: Maybe (Term Value) 63 | evalMEx = evalM (iConst 1 `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig) 64 | -------------------------------------------------------------------------------- /examples/Examples/Multi/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Examples.Multi.Common 6 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 7 | -- License : BSD3 8 | -- Maintainer : Tom Hvitved 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC Extensions) 11 | -- 12 | -- Common example files. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Examples.Multi.Common where 17 | 18 | import Data.Comp.Multi 19 | import Data.Comp.Multi.Show () 20 | import Data.Comp.Multi.Equality () 21 | import Data.Comp.Multi.Ordering () 22 | import Data.Comp.Multi.Derive 23 | 24 | -- Signature for values and operators 25 | data Value a i where 26 | Const :: Int -> Value a Int 27 | Pair :: a i -> a j -> Value a (i,j) 28 | data Op a i where 29 | Add, Mult :: a Int -> a Int -> Op a Int 30 | Fst :: a (i,j) -> Op a i 31 | Snd :: a (i,j) -> Op a j 32 | 33 | -- Signature for the simple expression language 34 | type Sig = Op :+: Value 35 | 36 | -- Derive boilerplate code using Template Haskell (GHC 7 needed) 37 | $(derive [makeHFunctor, makeHFoldable, makeHTraversable, makeShowHF, makeEqHF, 38 | makeOrdHF, smartConstructors, smartAConstructors] 39 | [''Value, ''Op]) -------------------------------------------------------------------------------- /examples/Examples/Multi/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs, 3 | ConstraintKinds #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Examples.Multi.Desugar 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- Desugaring 14 | -- 15 | -- The example illustrates how to compose a term homomorphism and an algebra, 16 | -- exemplified via a desugaring term homomorphism and an evaluation algebra. 17 | -- The example also illustrates how to lift a term homomorphism to products, 18 | -- exemplified via a desugaring term homomorphism lifted to terms annotated with 19 | -- source position information. 20 | -- 21 | -------------------------------------------------------------------------------- 22 | 23 | module Examples.Multi.Desugar where 24 | 25 | import Data.Comp.Multi 26 | import Data.Comp.Multi.Derive 27 | import Data.Comp.Multi.Desugar 28 | import Examples.Multi.Common 29 | import Examples.Multi.Eval 30 | 31 | -- Signature for syntactic sugar 32 | data Sugar a i where 33 | Neg :: a Int -> Sugar a Int 34 | Swap :: a (i,j) -> Sugar a (j,i) 35 | 36 | -- Source position information (line number, column number) 37 | data Pos = Pos Int Int 38 | deriving (Eq, Show) 39 | 40 | -- Signature for the simple expression language 41 | type SigP = Op :&: Pos :+: Value :&: Pos 42 | 43 | -- Signature for the simple expression language, extended with syntactic sugar 44 | type Sig' = Sugar :+: Op :+: Value 45 | type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos 46 | 47 | -- Derive boilerplate code using Template Haskell (GHC 7 needed) 48 | $(derive [makeHFunctor, makeHTraversable, makeHFoldable, makeEqHF, makeShowHF, 49 | makeOrdHF, smartConstructors, smartAConstructors] 50 | [''Sugar]) 51 | 52 | instance (Op :<: v, Value :<: v, HFunctor v) => Desugar Sugar v where 53 | desugHom' (Neg x) = iConst (-1) `iMult` x 54 | desugHom' (Swap x) = iSnd x `iPair` iFst x 55 | 56 | -- Compose the evaluation algebra and the desugaring homomorphism to an 57 | -- algebra 58 | evalDesug :: Term Sig' :-> Term Value 59 | evalDesug = cata (evalAlg `compAlg` (desugHom :: Hom Sig' Sig)) 60 | 61 | -- Example: evalEx = iPair (iConst 2) (iConst 1) 62 | evalEx :: Term Value (Int,Int) 63 | evalEx = evalDesug $ iSwap $ iPair (iConst 1) (iConst 2) 64 | 65 | -- Example: desugPEx = iAPair (Pos 1 0) 66 | -- (iASnd (Pos 1 0) (iAPair (Pos 1 1) 67 | -- (iAConst (Pos 1 2) 1) 68 | -- (iAConst (Pos 1 3) 2))) 69 | -- (iAFst (Pos 1 0) (iAPair (Pos 1 1) 70 | -- (iAConst (Pos 1 2) 1) 71 | -- (iAConst (Pos 1 3) 2))) 72 | desugPEx :: Term SigP (Int,Int) 73 | desugPEx = desugarA (iASwap (Pos 1 0) (iAPair (Pos 1 1) (iAConst (Pos 1 2) 1) 74 | (iAConst (Pos 1 3) 2)) 75 | :: Term SigP' (Int,Int)) 76 | -------------------------------------------------------------------------------- /examples/Examples/Multi/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs, 3 | ConstraintKinds #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Examples.Multi.Eval 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- Expression Evaluation 14 | -- 15 | -- The example illustrates how to use generalised compositional data types 16 | -- to implement a small expression language, with a sub language of values, and 17 | -- an evaluation function mapping expressions to values. 18 | -- 19 | -------------------------------------------------------------------------------- 20 | 21 | module Examples.Multi.Eval where 22 | 23 | import Data.Comp.Multi 24 | import Data.Comp.Multi.Derive 25 | import Examples.Multi.Common 26 | 27 | -- Term evaluation algebra 28 | class Eval f v where 29 | evalAlg :: Alg f (Term v) 30 | 31 | $(derive [liftSum] [''Eval]) 32 | 33 | -- Lift the evaluation algebra to a catamorphism 34 | eval :: (HFunctor f, Eval f v) => Term f :-> Term v 35 | eval = cata evalAlg 36 | 37 | instance {-# OVERLAPPABLE #-} (f :<: v) => Eval f v where 38 | evalAlg = inject -- default instance 39 | 40 | instance {-# OVERLAPPABLE #-} (Value :<: v) => Eval Op v where 41 | evalAlg (Add x y) = iConst $ projC x + projC y 42 | evalAlg (Mult x y) = iConst $ projC x * projC y 43 | evalAlg (Fst x) = fst $ projP x 44 | evalAlg (Snd x) = snd $ projP x 45 | 46 | projC :: (Value :<: v) => Term v Int -> Int 47 | projC v = case project v of Just (Const n) -> n 48 | 49 | projP :: (Value :<: v) => Term v (s,t) -> (Term v s, Term v t) 50 | projP v = case project v of Just (Pair x y) -> (x,y) 51 | 52 | -- Example: evalEx = iConst 2 53 | evalEx :: Term Value Int 54 | evalEx = eval (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int) 55 | -------------------------------------------------------------------------------- /examples/Examples/Multi/EvalI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Examples.Multi.EvalI 6 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 7 | -- License : BSD3 8 | -- Maintainer : Tom Hvitved 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC Extensions) 11 | -- 12 | -- Intrinsic, Tag-less Expression Evaluation 13 | -- 14 | -- The example illustrates how to use generalised compositional data types 15 | -- to implement a small expression language, and an evaluation function mapping 16 | -- intrinsically typed expressions to values. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Examples.Multi.EvalI where 21 | 22 | import Data.Comp.Multi 23 | import Data.Comp.Multi.Derive 24 | import Examples.Multi.Common 25 | 26 | -- Term evaluation algebra 27 | class EvalI f where 28 | evalAlgI :: Alg f I 29 | 30 | $(derive [liftSum] [''EvalI]) 31 | 32 | -- Lift the evaluation algebra to a catamorphism 33 | evalI :: (HFunctor f, EvalI f) => Term f i -> i 34 | evalI = unI . cata evalAlgI 35 | 36 | instance EvalI Value where 37 | evalAlgI (Const n) = I n 38 | evalAlgI (Pair (I x) (I y)) = I (x,y) 39 | 40 | instance EvalI Op where 41 | evalAlgI (Add (I x) (I y)) = I (x + y) 42 | evalAlgI (Mult (I x) (I y)) = I (x * y) 43 | evalAlgI (Fst (I (x,_))) = I x 44 | evalAlgI (Snd (I (_,y))) = I y 45 | 46 | -- Example: evalEx = 2 47 | evalIEx :: Int 48 | evalIEx = evalI (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int) -------------------------------------------------------------------------------- /examples/Examples/Multi/EvalM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs, 3 | ConstraintKinds #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Examples.Multi.EvalM 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- Monadic Expression Evaluation 14 | -- 15 | -- The example illustrates how to use generalised compositional data types to 16 | -- implement a small expression language, with a sub language of values, and a 17 | -- monadic evaluation function mapping expressions to values. 18 | -- 19 | -------------------------------------------------------------------------------- 20 | 21 | module Examples.Multi.EvalM where 22 | 23 | import Data.Comp.Multi 24 | import Data.Comp.Multi.Derive 25 | import Control.Monad (liftM) 26 | import Examples.Multi.Common 27 | 28 | -- Monadic term evaluation algebra 29 | class EvalM f v where 30 | evalAlgM :: AlgM Maybe f (Term v) 31 | 32 | $(derive [liftSum] [''EvalM]) 33 | 34 | evalM :: (HTraversable f, EvalM f v) => Term f i -> Maybe (Term v i) 35 | evalM = cataM evalAlgM 36 | 37 | instance {-# OVERLAPPABLE #-} (f :<: v) => EvalM f v where 38 | evalAlgM = return . inject -- default instance 39 | 40 | instance {-# OVERLAPPABLE #-} (Value :<: v) => EvalM Op v where 41 | evalAlgM (Add x y) = do n1 <- projC x 42 | n2 <- projC y 43 | return $ iConst $ n1 + n2 44 | evalAlgM (Mult x y) = do n1 <- projC x 45 | n2 <- projC y 46 | return $ iConst $ n1 * n2 47 | evalAlgM (Fst v) = liftM fst $ projP v 48 | evalAlgM (Snd v) = liftM snd $ projP v 49 | 50 | projC :: (Value :<: v) => Term v Int -> Maybe Int 51 | projC v = case project v of 52 | Just (Const n) -> return n; _ -> Nothing 53 | 54 | projP :: (Value :<: v) => Term v (a,b) -> Maybe (Term v a, Term v b) 55 | projP v = case project v of 56 | Just (Pair x y) -> return (x,y); _ -> Nothing 57 | 58 | -- Example: evalMEx = Just (iConst 5) 59 | evalMEx :: Maybe (Term Value Int) 60 | evalMEx = evalM (iConst 1 `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig Int) 61 | -------------------------------------------------------------------------------- /examples/Examples/Thunk.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, DeriveFunctor, 2 | FlexibleInstances, FlexibleContexts, UndecidableInstances, ConstraintKinds, 3 | CPP #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Examples.Thunk 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- This example illustrates how the ''Data.Comp.Thunk'' package can be 14 | -- used to implement a non-strict language (or a partially non-strict 15 | -- language). 16 | -- 17 | -------------------------------------------------------------------------------- 18 | 19 | module Examples.Thunk where 20 | 21 | import Data.Comp 22 | import Data.Comp.Thunk 23 | import Data.Comp.Derive 24 | import Data.Comp.Show() 25 | import Examples.Common hiding (Value(..), Sig, iConst, iPair) 26 | 27 | -- Control.Monad.Fail import is redundant since GHC 8.8.1 28 | #if !MIN_VERSION_base(4,13,0) 29 | import Control.Monad.Fail 30 | #endif 31 | 32 | -- Signature for values, strict pairs 33 | data Value a = Const Int | Pair !a !a deriving Functor 34 | 35 | -- Signature for the simple expression language 36 | type Sig = Op :+: Value 37 | 38 | -- Derive boilerplate code using Template Haskell 39 | $(derive [makeTraversable, makeFoldable, 40 | makeEqF, makeShowF, smartConstructors, makeHaskellStrict] 41 | [''Value]) 42 | 43 | -- Monadic term evaluation algebra 44 | class EvalT f m v where 45 | evalAlgT :: MonadFail m => AlgT m f v 46 | 47 | $(derive [liftSum] [''EvalT]) 48 | 49 | -- Lift the monadic evaluation algebra to a monadic catamorphism 50 | evalT :: (Traversable v, Functor f, EvalT f m v, MonadFail m) => Term f -> m (Term v) 51 | evalT = nf . cata evalAlgT 52 | 53 | instance (Value :<: m :+: v) => EvalT Value m v where 54 | -- make pairs strict in both components 55 | -- evalAlgT x@Pair{} = strict x 56 | -- or explicitly: 57 | -- evalAlgT (Pair x y) = thunk $ liftM2 iPair (dethunk' x) (dethunk' )y 58 | -- evalAlgT x = inject x 59 | 60 | -- or only partially strict 61 | evalAlgT = haskellStrict' 62 | 63 | instance (Value :<: m :+: v, Value :<: v) => EvalT Op m v where 64 | evalAlgT (Add x y) = thunk $ do 65 | Const n1 <- whnfPr x 66 | Const n2 <- whnfPr y 67 | return $ iConst $ n1 + n2 68 | evalAlgT (Mult x y) = thunk $ do 69 | Const n1 <- whnfPr x 70 | Const n2 <- whnfPr y 71 | return $ iConst $ n1 * n2 72 | evalAlgT (Fst v) = thunk $ do 73 | Pair x _ <- whnfPr v 74 | return x 75 | evalAlgT (Snd v) = thunk $ do 76 | Pair _ y <- whnfPr v 77 | return y 78 | 79 | 80 | instance MonadFail (Either String) where 81 | fail = Left 82 | 83 | evalTEx :: Either String (Term Value) 84 | evalTEx = evalT (iSnd (iFst (iConst 5) `iPair` iConst 4) :: Term Sig) 85 | -------------------------------------------------------------------------------- /runbenchmarks: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | cabal bench --benchmark-option=--summary=benchmark-results/results.csv -------------------------------------------------------------------------------- /src/Data/Comp.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.Comp 4 | -- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved 5 | -- License : BSD3 6 | -- Maintainer : Patrick Bahr , Tom Hvitved 7 | -- Stability : experimental 8 | -- Portability : non-portable (GHC Extensions) 9 | -- 10 | -- This module defines the infrastructure necessary to use 11 | -- /Compositional Data Types/. Compositional Data Types is an extension of 12 | -- Wouter Swierstra's Functional Pearl: /Data types a la carte/. Examples of 13 | -- usage are bundled with the package in the library @examples\/Examples@. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | module Data.Comp 17 | ( 18 | module X 19 | ) where 20 | 21 | import Data.Comp.Algebra as X 22 | import Data.Comp.Annotation as X 23 | import Data.Comp.Equality as X 24 | import Data.Comp.Generic as X 25 | import Data.Comp.Ordering as X 26 | import Data.Comp.Sum as X 27 | import Data.Comp.Term as X 28 | -------------------------------------------------------------------------------- /src/Data/Comp/Annotation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | -------------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Data.Comp.Annotation 13 | -- Copyright : (c) 2010-2013 Patrick Bahr 14 | -- License : BSD3 15 | -- Maintainer : Patrick Bahr 16 | -- Stability : experimental 17 | -- Portability : non-portable (GHC Extensions) 18 | -- 19 | -- This module defines annotations on signatures. 20 | -- 21 | -------------------------------------------------------------------------------- 22 | 23 | module Data.Comp.Annotation 24 | ( 25 | (:&:) (..), 26 | (:*:) (..), 27 | DistAnn (..), 28 | RemA (..), 29 | liftA, 30 | liftA', 31 | stripA, 32 | propAnn, 33 | propAnnM, 34 | ann, 35 | project' 36 | ) where 37 | 38 | import Control.Monad 39 | import Data.Comp.Algebra 40 | import Data.Comp.Ops 41 | import Data.Comp.Term 42 | 43 | 44 | {-| Transform a function with a domain constructed from a functor to a function 45 | with a domain constructed with the same functor, but with an additional 46 | annotation. -} 47 | liftA :: (RemA s s') => (s' a -> t) -> s a -> t 48 | liftA f v = f (remA v) 49 | 50 | {-| Transform a function with a domain constructed from a functor to a function 51 | with a domain constructed with the same functor, but with an additional 52 | annotation. -} 53 | liftA' :: (DistAnn s' p s, Functor s') 54 | => (s' a -> Cxt h s' a) -> s a -> Cxt h s a 55 | liftA' f v = let (v',p) = projectA v 56 | in ann p (f v') 57 | 58 | {-| Strip the annotations from a term over a functor with annotations. -} 59 | stripA :: (RemA g f, Functor g) => CxtFun g f 60 | stripA = appSigFun remA 61 | 62 | {-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism 63 | over the same signatures, but extended with annotations. -} 64 | propAnn :: (DistAnn f p f', DistAnn g p g', Functor g) 65 | => Hom f g -> Hom f' g' 66 | propAnn hom f' = ann p (hom f) 67 | where (f,p) = projectA f' 68 | 69 | 70 | {-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic 71 | term homomorphism over the same signatures, but extended with annotations. -} 72 | propAnnM :: (DistAnn f p f', DistAnn g p g', Functor g, Monad m) 73 | => HomM m f g -> HomM m f' g' 74 | propAnnM hom f' = liftM (ann p) (hom f) 75 | where (f,p) = projectA f' 76 | 77 | {-| Annotate each node of a term with a constant value. -} 78 | ann :: (DistAnn f p g, Functor f) => p -> CxtFun f g 79 | ann c = appSigFun (injectA c) 80 | 81 | 82 | {-| This function is similar to 'project' but applies to signatures 83 | with an annotation which is then ignored. -} 84 | project' :: (RemA f f', s :<: f') => Cxt h f a -> Maybe (s (Cxt h f a)) 85 | project' (Term x) = proj $ remA x 86 | project' _ = Nothing 87 | -------------------------------------------------------------------------------- /src/Data/Comp/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | -------------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Comp.Arbitrary 9 | -- Copyright : (c) 2011 Patrick Bahr 10 | -- License : BSD3 11 | -- Maintainer : Patrick Bahr 12 | -- Stability : experimental 13 | -- Portability : non-portable (GHC Extensions) 14 | -- 15 | -- This module defines generation of arbitrary values for signatures, which 16 | -- lifts to generating arbitrary terms. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Data.Comp.Arbitrary 21 | ( ArbitraryF(..) 22 | )where 23 | 24 | import Data.Comp.Derive 25 | import Data.Comp.Derive.Utils 26 | import Data.Comp.Ops 27 | import Data.Comp.Term 28 | import Test.QuickCheck 29 | 30 | {-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary' 31 | for the corresponding term type. -} 32 | 33 | instance (ArbitraryF f) => Arbitrary (Term f) where 34 | arbitrary = Term <$> arbitraryF 35 | shrink (Term expr) = map Term $ shrinkF expr 36 | 37 | instance (ArbitraryF f, Arbitrary p) => ArbitraryF (f :&: p) where 38 | arbitraryF' = map addP arbitraryF' 39 | where addP (i,gen) = (i,(:&:) <$> gen <*> arbitrary) 40 | arbitraryF = (:&:) <$> arbitraryF <*> arbitrary 41 | shrinkF (v :&: p) = drop 1 [v' :&: p'| v' <- v: shrinkF v, p' <- p : shrink p ] 42 | 43 | {-| 44 | This lifts instances of 'ArbitraryF' to instances of 'ArbitraryF' for 45 | the corresponding context functor. 46 | -} 47 | instance (ArbitraryF f) => ArbitraryF (Context f) where 48 | arbitraryF = oneof [Term <$> arbitraryF , Hole <$> arbitrary] 49 | shrinkF (Term expr) = map Term $ shrinkF expr 50 | shrinkF (Hole a) = map Hole $ shrink a 51 | 52 | 53 | {-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary' 54 | for the corresponding context type. -} 55 | 56 | instance (ArbitraryF f, Arbitrary a) => Arbitrary (Context f a) where 57 | arbitrary = arbitraryF 58 | shrink = shrinkF 59 | 60 | 61 | {-| Instances of 'ArbitraryF' are closed under forming sums. -} 62 | 63 | instance (ArbitraryF f , ArbitraryF g) => ArbitraryF (f :+: g) where 64 | arbitraryF' = map inl arbitraryF' ++ map inr arbitraryF' 65 | where inl (i,gen) = (i,Inl <$> gen) 66 | inr (i,gen) = (i,Inr <$> gen) 67 | shrinkF (Inl val) = map Inl (shrinkF val) 68 | shrinkF (Inr val) = map Inr (shrinkF val) 69 | 70 | 71 | $(derive [makeArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10) 72 | -------------------------------------------------------------------------------- /src/Data/Comp/Decompose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | 6 | -------------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Comp.Decompose 9 | -- Copyright : (c) 2010-2011 Patrick Bahr 10 | -- License : BSD3 11 | -- Maintainer : Patrick Bahr 12 | -- Stability : experimental 13 | -- Portability : non-portable (GHC Extensions) 14 | -- 15 | -- This module implements the decomposition of terms into function 16 | -- symbols and arguments resp. variables. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | module Data.Comp.Decompose ( 20 | Decomp (..), 21 | DecompTerm, 22 | Decompose, 23 | decomp, 24 | structure, 25 | arguments, 26 | decompose 27 | ) where 28 | 29 | import Data.Comp.Term 30 | import Data.Comp.Variables 31 | import Data.Foldable 32 | 33 | {-| This function computes the structure of a functorial value. -} 34 | 35 | structure :: (Functor f) => f a -> Const f 36 | structure = fmap (const ()) 37 | 38 | {-| This function computes the arguments of a functorial value. -} 39 | 40 | arguments :: (Foldable f) => f a -> [a] 41 | arguments = toList 42 | 43 | {-| This type represents decompositions of functorial values. -} 44 | 45 | data Decomp f v a = Var v 46 | | Fun (Const f) [a] 47 | 48 | {-| This type represents decompositions of terms. -} 49 | 50 | type DecompTerm f v = Decomp f v (Term f) 51 | 52 | {-| This class specifies the decomposability of a functorial value. -} 53 | 54 | type Decompose f v = (HasVars f v, Functor f, Foldable f) 55 | 56 | decomp :: Decompose f v => f a -> Decomp f v a 57 | decomp t = case isVar t of 58 | Just v -> Var v 59 | Nothing -> Fun sym args 60 | where sym = fmap (const ()) t 61 | args = arguments t 62 | 63 | 64 | {-| This function decomposes a term. -} 65 | 66 | decompose :: Decompose f v => Term f -> DecompTerm f v 67 | decompose (Term t) = decomp t 68 | -------------------------------------------------------------------------------- /src/Data/Comp/DeepSeq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | -------------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Comp.DeepSeq 9 | -- Copyright : (c) 2010-2011 Patrick Bahr 10 | -- License : BSD3 11 | -- Maintainer : Patrick Bahr 12 | -- Stability : experimental 13 | -- Portability : non-portable (GHC Extensions) 14 | -- 15 | -- This module defines full evaluation of signatures, which lifts to full 16 | -- evaluation of terms and contexts. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Data.Comp.DeepSeq 21 | ( 22 | NFDataF(..) 23 | ) 24 | where 25 | 26 | import Control.DeepSeq 27 | import Data.Comp.Annotation 28 | import Data.Comp.Derive 29 | import Data.Comp.Term 30 | 31 | 32 | instance (NFDataF f, NFData a) => NFData (Cxt h f a) where 33 | rnf (Hole x) = rnf x 34 | rnf (Term x) = rnfF x 35 | 36 | instance (NFDataF f, NFData a) => NFDataF (f :&: a) where 37 | rnfF (f :&: a) = rnfF f `seq` rnf a 38 | 39 | 40 | $(derive [liftSum] [''NFDataF]) 41 | $(derive [makeNFDataF] [''Maybe, ''[], ''(,)]) 42 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Derive 5 | -- Copyright : (c) 2010-2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- This module contains functionality for automatically deriving boilerplate 12 | -- code using Template Haskell. Examples include instances of 'Functor', 13 | -- 'Foldable', and 'Traversable'. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Data.Comp.Derive 18 | ( 19 | derive, 20 | -- |Derive boilerplate instances for compositional data type signatures. 21 | 22 | -- ** ShowF 23 | module Data.Comp.Derive.Show, 24 | -- ** EqF 25 | module Data.Comp.Derive.Equality, 26 | -- ** OrdF 27 | module Data.Comp.Derive.Ordering, 28 | -- ** Foldable 29 | module Data.Comp.Derive.Foldable, 30 | -- ** Traversable 31 | module Data.Comp.Derive.Traversable, 32 | -- ** HaskellStrict 33 | module Data.Comp.Derive.HaskellStrict, 34 | -- ** Arbitrary 35 | module Data.Comp.Derive.Arbitrary, 36 | NFData(..), 37 | -- ** DeepSeq 38 | module Data.Comp.Derive.DeepSeq, 39 | -- ** Smart Constructors 40 | module Data.Comp.Derive.SmartConstructors, 41 | -- ** Smart Constructors w/ Annotations 42 | module Data.Comp.Derive.SmartAConstructors, 43 | -- ** Lifting to Sums 44 | liftSum 45 | ) where 46 | 47 | import Control.DeepSeq (NFData (..)) 48 | import Data.Comp.Derive.Arbitrary 49 | import Data.Comp.Derive.DeepSeq 50 | import Data.Comp.Derive.Equality 51 | import Data.Comp.Derive.Foldable 52 | import Data.Comp.Derive.HaskellStrict 53 | import Data.Comp.Derive.Ordering 54 | import Data.Comp.Derive.Show 55 | import Data.Comp.Derive.SmartAConstructors 56 | import Data.Comp.Derive.SmartConstructors 57 | import Data.Comp.Derive.Traversable 58 | import Data.Comp.Derive.Utils (derive, liftSumGen) 59 | import Data.Comp.Ops ((:+:), caseF) 60 | 61 | import Language.Haskell.TH 62 | 63 | 64 | 65 | 66 | {-| Given the name of a type class, where the first parameter is a functor, 67 | lift it to sums of functors. Example: @class ShowF f where ...@ is lifted 68 | as @instance (ShowF f, ShowF g) => ShowF (f :+: g) where ... @. -} 69 | liftSum :: Name -> Q [Dec] 70 | liftSum = liftSumGen 'caseF ''(:+:) 71 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive/DeepSeq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Derive.DeepSeq 5 | -- Copyright : (c) 2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive instances of @DeepSeq@. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Derive.DeepSeq 16 | ( 17 | NFDataF(..), 18 | makeNFDataF 19 | ) where 20 | 21 | 22 | import Control.DeepSeq 23 | import Data.Comp.Derive.Utils 24 | import Language.Haskell.TH 25 | 26 | {-| Signature normal form. An instance @NFDataF f@ gives rise to an instance 27 | @NFData (Term f)@. -} 28 | class NFDataF f where 29 | rnfF :: NFData a => f a -> () 30 | 31 | {-| Derive an instance of 'NFDataF' for a type constructor of any first-order 32 | kind taking at least one argument. -} 33 | makeNFDataF :: Name -> Q [Dec] 34 | makeNFDataF fname = do 35 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 36 | let argNames = map (VarT . tyVarBndrName) (init args) 37 | complType = foldl AppT (ConT name) argNames 38 | preCond = map (mkClassP ''NFData . (: [])) argNames 39 | classType = AppT (ConT ''NFDataF) complType 40 | constrs' <- mapM normalConExp constrs 41 | rnfFDecl <- funD 'rnfF (rnfFClauses constrs') 42 | return [mkInstanceD preCond classType [rnfFDecl]] 43 | where rnfFClauses = map genRnfFClause 44 | genRnfFClause (constr, args,_) = do 45 | let n = length args 46 | varNs <- newNames n "x" 47 | let pat = ConP constr [] $ map VarP varNs 48 | allVars = map varE varNs 49 | body <- foldr (\ x y -> [|rnf $x `seq` $y|]) [| () |] allVars 50 | return $ Clause [pat] (NormalB body) [] 51 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Derive.Equality 5 | -- Copyright : (c) 2010-2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive instances of @EqF@. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | module Data.Comp.Derive.Equality 15 | ( 16 | EqF(..), 17 | makeEqF 18 | ) where 19 | 20 | import Data.Comp.Derive.Utils 21 | import Language.Haskell.TH hiding (Cxt, match) 22 | 23 | 24 | {-| Signature equality. An instance @EqF f@ gives rise to an instance 25 | @Eq (Term f)@. -} 26 | class EqF f where 27 | 28 | eqF :: Eq a => f a -> f a -> Bool 29 | 30 | {-| Derive an instance of 'EqF' for a type constructor of any first-order kind 31 | taking at least one argument. -} 32 | makeEqF :: Name -> Q [Dec] 33 | makeEqF fname = do 34 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 35 | let argNames = map (VarT . tyVarBndrName) (init args) 36 | complType = foldl AppT (ConT name) argNames 37 | preCond = map (mkClassP ''Eq . (: [])) argNames 38 | classType = AppT (ConT ''EqF) complType 39 | eqFDecl <- funD 'eqF (eqFClauses constrs) 40 | return [mkInstanceD preCond classType [eqFDecl]] 41 | where eqFClauses constrs = map (genEqClause.abstractConType) constrs 42 | ++ defEqClause constrs 43 | defEqClause constrs 44 | | length constrs < 2 = [] 45 | | otherwise = [clause [wildP,wildP] (normalB [|False|]) []] 46 | genEqClause (constr, n) = do 47 | varNs <- newNames n "x" 48 | varNs' <- newNames n "y" 49 | let pat = ConP constr [] $ map VarP varNs 50 | pat' = ConP constr [] $ map VarP varNs' 51 | vars = map VarE varNs 52 | vars' = map VarE varNs' 53 | mkEq x y = let (x',y') = (return x,return y) 54 | in [| $x' == $y'|] 55 | eqs = listE $ zipWith mkEq vars vars' 56 | body <- if n == 0 57 | then [|True|] 58 | else [|and $eqs|] 59 | return $ Clause [pat, pat'] (NormalB body) [] 60 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive/LiftSum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Comp.Derive.LiftSum 6 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 7 | -- License : BSD3 8 | -- Maintainer : Tom Hvitved 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC Extensions) 11 | -- 12 | -- Lift a class declaration for difunctors to sums of functors. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Data.Comp.Derive.LiftSum 17 | ( 18 | liftSum, 19 | caseF 20 | ) where 21 | 22 | import Data.Comp.Derive.Utils 23 | import Data.Comp.Ops ((:+:) (..)) 24 | import Data.Comp.Sum 25 | import Language.Haskell.TH hiding (Cxt) 26 | 27 | 28 | {-| Given the name of a type class, where the first parameter is a functor, 29 | lift it to sums of functors. Example: @class ShowF f where ...@ is lifted 30 | as @instance (ShowF f, ShowF g) => ShowF (f :+: g) where ... @. -} 31 | liftSum :: Name -> Q [Dec] 32 | liftSum = liftSumGen 'caseF ''(:+:) 33 | 34 | 35 | 36 | {-| Utility function to case on a functor sum, without exposing the internal 37 | representation of sums. -} 38 | caseF :: (f a -> b) -> (g a -> b) -> (f :+: g) a -> b 39 | {-# INLINE caseF #-} 40 | caseF f g x = case x of 41 | Inl x -> f x 42 | Inr x -> g x 43 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive/Ordering.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Derive.Ordering 5 | -- Copyright : (c) 2010-2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive instances of @OrdF@. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | module Data.Comp.Derive.Ordering 15 | ( 16 | OrdF(..), 17 | makeOrdF 18 | ) where 19 | 20 | import Data.Comp.Derive.Equality 21 | import Data.Comp.Derive.Utils 22 | 23 | import Data.List 24 | import Data.Maybe 25 | import Language.Haskell.TH hiding (Cxt) 26 | 27 | {-| Signature ordering. An instance @OrdF f@ gives rise to an instance 28 | @Ord (Term f)@. -} 29 | class EqF f => OrdF f where 30 | compareF :: Ord a => f a -> f a -> Ordering 31 | 32 | 33 | compList :: [Ordering] -> Ordering 34 | compList = fromMaybe EQ . find (/= EQ) 35 | 36 | {-| Derive an instance of 'OrdF' for a type constructor of any first-order kind 37 | taking at least one argument. -} 38 | makeOrdF :: Name -> Q [Dec] 39 | makeOrdF fname = do 40 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 41 | let argNames = map (VarT . tyVarBndrName) (init args) 42 | complType = foldl AppT (ConT name) argNames 43 | preCond = map (mkClassP ''Ord . (: [])) argNames 44 | classType = AppT (ConT ''OrdF) complType 45 | eqAlgDecl <- funD 'compareF (compareFClauses constrs) 46 | return [mkInstanceD preCond classType [eqAlgDecl]] 47 | where compareFClauses [] = [] 48 | compareFClauses constrs = 49 | let constrs' = map abstractConType constrs `zip` [1..] 50 | constPairs = [(x,y)| x<-constrs', y <- constrs'] 51 | in map genClause constPairs 52 | genClause ((c,n),(d,m)) 53 | | n == m = genEqClause c 54 | | n < m = genLtClause c d 55 | | otherwise = genGtClause c d 56 | genEqClause (constr, n) = do 57 | varNs <- newNames n "x" 58 | varNs' <- newNames n "y" 59 | let pat = ConP constr [] $ map VarP varNs 60 | pat' = ConP constr [] $ map VarP varNs' 61 | vars = map VarE varNs 62 | vars' = map VarE varNs' 63 | mkEq x y = let (x',y') = (return x,return y) 64 | in [| compare $x' $y'|] 65 | eqs = listE $ zipWith mkEq vars vars' 66 | body <- [|compList $eqs|] 67 | return $ Clause [pat, pat'] (NormalB body) [] 68 | genLtClause (c, _) (d, _) = clause [recP c [], recP d []] (normalB [| LT |]) [] 69 | genGtClause (c, _) (d, _) = clause [recP c [], recP d []] (normalB [| GT |]) [] 70 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Derive.Show 5 | -- Copyright : (c) 2010-2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive instances of @ShowF@. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Derive.Show 16 | ( 17 | ShowF(..), 18 | makeShowF, 19 | ShowConstr(..), 20 | makeShowConstr 21 | ) where 22 | 23 | import Data.Comp.Derive.Utils 24 | import Language.Haskell.TH 25 | 26 | {-| Signature printing. An instance @ShowF f@ gives rise to an instance 27 | @Show (Term f)@. -} 28 | class ShowF f where 29 | showF :: f String -> String 30 | 31 | showCon :: String -> [String] -> String 32 | showCon con [] = con 33 | showCon con args = "(" ++ con ++ " " ++ unwords args ++ ")" 34 | 35 | {-| Derive an instance of 'ShowF' for a type constructor of any first-order kind 36 | taking at least one argument. -} 37 | makeShowF :: Name -> Q [Dec] 38 | makeShowF fname = do 39 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 40 | let fArg = VarT . tyVarBndrName $ last args 41 | argNames = map (VarT . tyVarBndrName) (init args) 42 | complType = foldl AppT (ConT name) argNames 43 | preCond = map (mkClassP ''Show . (: [])) argNames 44 | classType = AppT (ConT ''ShowF) complType 45 | constrs' <- mapM normalConExp constrs 46 | showFDecl <- funD 'showF (showFClauses fArg constrs') 47 | return [mkInstanceD preCond classType [showFDecl]] 48 | where showFClauses fArg = map (genShowFClause fArg) 49 | filterFarg fArg ty x = (fArg == ty, varE x) 50 | mkShow :: (Bool, ExpQ) -> ExpQ 51 | mkShow (isFArg, var) 52 | | isFArg = var 53 | | otherwise = [| show $var |] 54 | genShowFClause fArg (constr, args, gadtTy) = do 55 | let n = length args 56 | varNs <- newNames n "x" 57 | let pat = ConP constr [] $ map VarP varNs 58 | allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs 59 | shows = listE $ map mkShow allVars 60 | conName = nameBase constr 61 | body <- [|showCon conName $shows|] 62 | return $ Clause [pat] (NormalB body) [] 63 | 64 | {-| Constructor printing. -} 65 | class ShowConstr f where 66 | showConstr :: f a -> String 67 | 68 | showCon' :: String -> [String] -> String 69 | showCon' con args = unwords $ con : filter (not.null) args 70 | 71 | {-| Derive an instance of 'showConstr' for a type constructor of any first-order kind 72 | taking at least one argument. -} 73 | makeShowConstr :: Name -> Q [Dec] 74 | makeShowConstr fname = do 75 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 76 | let fArg = VarT . tyVarBndrName $ last args 77 | argNames = map (VarT . tyVarBndrName) (init args) 78 | complType = foldl AppT (ConT name) argNames 79 | preCond = map (mkClassP ''Show . (: [])) argNames 80 | classType = AppT (ConT ''ShowConstr) complType 81 | constrs' <- mapM normalConExp constrs 82 | showConstrDecl <- funD 'showConstr (showConstrClauses fArg constrs') 83 | return [mkInstanceD preCond classType [showConstrDecl]] 84 | where showConstrClauses fArg = map (genShowConstrClause fArg) 85 | filterFarg fArg ty x = (fArg == ty, varE x) 86 | mkShow :: (Bool, ExpQ) -> ExpQ 87 | mkShow (isFArg, var) 88 | | isFArg = [| "" |] 89 | | otherwise = [| show $var |] 90 | genShowConstrClause fArg (constr, args, gadtTy) = do 91 | let n = length args 92 | varNs <- newNames n "x" 93 | let pat = ConP constr [] $ map VarP varNs 94 | allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs 95 | shows = listE $ map mkShow allVars 96 | conName = nameBase constr 97 | body <- [|showCon' conName $shows|] 98 | return $ Clause [pat] (NormalB body) [] 99 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive/SmartAConstructors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Derive.SmartAConstructors 5 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 6 | -- License : BSD3 7 | -- Maintainer : Tom Hvitved 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive smart constructors with annotations. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Derive.SmartAConstructors 16 | ( 17 | smartAConstructors 18 | ) where 19 | 20 | import Control.Monad 21 | import Data.Comp.Annotation 22 | import Data.Comp.Derive.Utils 23 | import Data.Comp.Sum 24 | import Data.Comp.Term 25 | import Language.Haskell.TH hiding (Cxt) 26 | 27 | {-| Derive smart constructors with products for a type constructor of any 28 | parametric kind taking at least one argument. The smart constructors are 29 | similar to the ordinary constructors, but an 'injectA' is automatically 30 | inserted. -} 31 | smartAConstructors :: Name -> Q [Dec] 32 | smartAConstructors fname = do 33 | Just (DataInfo _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname 34 | let cons = map abstractConType constrs 35 | liftM concat $ mapM genSmartConstr cons 36 | where genSmartConstr (name, args) = do 37 | let bname = nameBase name 38 | genSmartConstr' (mkName $ "iA" ++ bname) name args 39 | genSmartConstr' sname name args = do 40 | varNs <- newNames args "x" 41 | varPr <- newName "_p" 42 | let pats = map varP (varPr : varNs) 43 | vars = map varE varNs 44 | val = appE [|injectA $(varE varPr)|] $ 45 | appE [|inj|] $ foldl appE (conE name) vars 46 | function = [funD sname [clause pats (normalB [|Term $val|]) []]] 47 | sequence function 48 | -------------------------------------------------------------------------------- /src/Data/Comp/Derive/SmartConstructors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Derive.Signature 5 | -- Copyright : (c) 2010-2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive smart constructors. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Derive.SmartConstructors 16 | ( 17 | smartConstructors 18 | ) where 19 | 20 | import Control.Monad 21 | import Data.Comp.Derive.Utils 22 | import Data.Comp.Sum 23 | import Data.Comp.Term 24 | import Language.Haskell.TH hiding (Cxt) 25 | 26 | {-| Derive smart constructors for a type constructor of any first-order kind 27 | taking at least one argument. The smart constructors are similar to the 28 | ordinary constructors, but an 'inject' is automatically inserted. -} 29 | smartConstructors :: Name -> Q [Dec] 30 | smartConstructors fname = do 31 | Just (DataInfo _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname 32 | let cons = map abstractConType constrs 33 | liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons 34 | where genSmartConstr targs tname (name, args) = do 35 | let bname = nameBase name 36 | genSmartConstr' targs tname (mkName $ 'i' : bname) name args 37 | genSmartConstr' targs tname sname name args = do 38 | varNs <- newNames args "x" 39 | let pats = map varP varNs 40 | vars = map varE varNs 41 | val = foldl appE (conE name) vars 42 | sig = genSig targs tname sname args 43 | function = [funD sname [clause pats (normalB [|inject $val|]) []]] 44 | sequence $ sig ++ function 45 | genSig targs tname sname 0 = (:[]) $ do 46 | let fvar = mkName "f" 47 | hvar = mkName "h" 48 | avar = mkName "a" 49 | targs' = init targs 50 | vars = fvar:hvar:avar:targs' 51 | f = varT fvar 52 | h = varT hvar 53 | a = varT avar 54 | ftype = foldl appT (conT tname) (map varT targs') 55 | constr = (conT ''(:<:) `appT` ftype) `appT` f 56 | typ = foldl appT (conT ''Cxt) [h, f, a] 57 | typeSig = forallT (map (\ v -> PlainTV v SpecifiedSpec) vars) (sequence [constr]) typ 58 | sigD sname typeSig 59 | genSig _ _ _ _ = [] 60 | -------------------------------------------------------------------------------- /src/Data/Comp/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Comp.Desugar 10 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 11 | -- License : BSD3 12 | -- Maintainer : Tom Hvitved 13 | -- Stability : experimental 14 | -- Portability : non-portable (GHC Extensions) 15 | -- 16 | -- This modules defines the 'Desugar' type class for desugaring of terms. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | 20 | module Data.Comp.Desugar where 21 | 22 | import Data.Comp 23 | 24 | -- |The desugaring term homomorphism. 25 | class (Functor f, Functor g) => Desugar f g where 26 | desugHom :: Hom f g 27 | desugHom = desugHom' . fmap Hole 28 | desugHom' :: Alg f (Context g a) 29 | desugHom' x = appCxt (desugHom x) 30 | 31 | -- We make the lifting to sums explicit in order to make the Desugar 32 | -- class work with the default instance declaration further below. 33 | instance {-# OVERLAPPABLE #-} (Desugar f h, Desugar g h) => Desugar (f :+: g) h where 34 | desugHom = caseF desugHom desugHom 35 | 36 | -- |Desugar a term. 37 | desugar :: Desugar f g => Term f -> Term g 38 | {-# INLINE desugar #-} 39 | desugar = appHom desugHom 40 | 41 | -- |Lift desugaring to annotated terms. 42 | desugarA :: (Functor f', Functor g', DistAnn f p f', DistAnn g p g', 43 | Desugar f g) => Term f' -> Term g' 44 | desugarA = appHom (propAnn desugHom) 45 | 46 | -- |Default desugaring instance. 47 | instance {-# OVERLAPPABLE #-} (Functor f, Functor g, f :<: g) => Desugar f g where 48 | desugHom = simpCxt . inj 49 | -------------------------------------------------------------------------------- /src/Data/Comp/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.Comp.Equality 7 | -- Copyright : (c) 2010-2011 Patrick Bahr 8 | -- License : BSD3 9 | -- Maintainer : Patrick Bahr 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- This module defines equality for signatures, which lifts to equality for 14 | -- terms and contexts. 15 | -- 16 | -------------------------------------------------------------------------------- 17 | module Data.Comp.Equality 18 | ( 19 | EqF(..), 20 | eqMod, 21 | ) where 22 | 23 | import Control.Monad hiding (mapM_) 24 | import Data.Comp.Derive.Equality 25 | import Data.Comp.Derive.Utils 26 | import Data.Comp.Ops 27 | import Data.Comp.Term 28 | import Data.Foldable 29 | import Prelude hiding (all, mapM_) 30 | 31 | -- instance (EqF f, Eq p) => EqF (f :*: p) where 32 | -- eqF (v1 :*: p1) (v2 :*: p2) = p1 == p2 && v1 `eqF` v2 33 | 34 | {-| 35 | From an 'EqF' functor an 'Eq' instance of the corresponding 36 | term type can be derived. 37 | -} 38 | instance (EqF f, Eq a) => Eq (Cxt h f a) where 39 | (==) = eqF 40 | 41 | instance (EqF f) => EqF (Cxt h f) where 42 | eqF (Term e1) (Term e2) = e1 `eqF` e2 43 | eqF (Hole h1) (Hole h2) = h1 == h2 44 | eqF _ _ = False 45 | 46 | {-| 47 | 'EqF' is propagated through sums. 48 | -} 49 | instance (EqF f, EqF g) => EqF (f :+: g) where 50 | eqF (Inl x) (Inl y) = eqF x y 51 | eqF (Inr x) (Inr y) = eqF x y 52 | eqF _ _ = False 53 | 54 | {-| This function implements equality of values of type @f a@ modulo 55 | the equality of @a@ itself. If two functorial values are equal in this 56 | sense, 'eqMod' returns a 'Just' value containing a list of pairs 57 | consisting of corresponding components of the two functorial 58 | values. -} 59 | eqMod :: (EqF f, Functor f, Foldable f) => f a -> f b -> Maybe [(a,b)] 60 | eqMod s t 61 | | unit s `eqF` unit' t = Just args 62 | | otherwise = Nothing 63 | where unit = fmap (const ()) 64 | unit' = fmap (const ()) 65 | args = toList s `zip` toList t 66 | 67 | $(derive [makeEqF] $ [''Maybe, ''[]] ++ tupleTypes 2 10) 68 | -------------------------------------------------------------------------------- /src/Data/Comp/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Comp.Generic 10 | -- Copyright : (c) 2011 Patrick Bahr 11 | -- License : BSD3 12 | -- Maintainer : Patrick Bahr 13 | -- Stability : experimental 14 | -- Portability : non-portable (GHC Extensions) 15 | -- 16 | -- This module defines type generic functions and recursive schemes 17 | -- along the lines of the Uniplate library. 18 | -- 19 | -------------------------------------------------------------------------------- 20 | 21 | module Data.Comp.Generic where 22 | 23 | import Control.Monad hiding (mapM) 24 | import Data.Comp.Algebra 25 | import Data.Comp.Sum 26 | import Data.Comp.Term 27 | import Data.Foldable 28 | import Data.Maybe 29 | import Data.Traversable 30 | import GHC.Exts (build) 31 | import Prelude hiding (foldl, mapM) 32 | 33 | 34 | -- | This function returns the subterm of a given term at the position 35 | -- specified by the given path or @Nothing@ if the input term has no 36 | -- such subterm 37 | 38 | getSubterm :: (Functor g, Foldable g) => [Int] -> Term g -> Maybe (Term g) 39 | getSubterm path t = cata alg t path where 40 | alg :: (Functor g, Foldable g) => Alg g ([Int] -> Maybe (Cxt h g a)) 41 | alg t [] = Just $ Term $ fmap ((fromJust) . ($ [])) t 42 | alg t (i:is) = case drop i (toList t) of 43 | [] -> Nothing 44 | x : _ -> x is 45 | 46 | -- | This function returns a list of all subterms of the given 47 | -- term. This function is similar to Uniplate's @universe@ function. 48 | subterms :: forall f . Foldable f => Term f -> [Term f] 49 | subterms t = build (f t) 50 | where f :: Term f -> (Term f -> b -> b) -> b -> b 51 | f t cons nil = t `cons` foldl (\u s -> f s cons u) nil (unTerm t) 52 | -- universe t = t : foldl (\u s -> u ++ universe s) [] (unTerm t) 53 | 54 | 55 | -- | This function returns a list of all subterms of the given term 56 | -- that are constructed from a particular functor. 57 | subterms' :: forall f g . (Foldable f, g :<: f) => Term f -> [g (Term f)] 58 | subterms' (Term t) = build (f t) 59 | where f :: f (Term f) -> (g (Term f) -> b -> b) -> b -> b 60 | f t cons nil = let rest = foldl (\u (Term s) -> f s cons u) nil t 61 | in case proj t of 62 | Just t' -> t'`cons` rest 63 | Nothing -> rest 64 | 65 | -- | This function transforms every subterm according to the given 66 | -- function in a bottom-up manner. This function is similar to 67 | -- Uniplate's @transform@ function. 68 | transform :: (Functor f) => (Term f -> Term f) -> Term f -> Term f 69 | transform f = run 70 | where run = f . Term . fmap run . unTerm 71 | -- transform f = f . Term . fmap (transform f) . unTerm 72 | 73 | transform' :: (Functor f) => (Term f -> Maybe (Term f)) -> Term f -> Term f 74 | transform' f = transform f' where 75 | f' t = fromMaybe t (f t) 76 | 77 | 78 | -- | Monadic version of 'transform'. 79 | transformM :: (Traversable f, Monad m) => 80 | (Term f -> m (Term f)) -> Term f -> m (Term f) 81 | transformM f = run 82 | where run t = f =<< liftM Term (mapM run $ unTerm t) 83 | 84 | query :: Foldable f => (Term f -> r) -> (r -> r -> r) -> Term f -> r 85 | query q c = run 86 | where run i@(Term t) = foldl (\s x -> s `c` run x) (q i) t 87 | -- query q c i@(Term t) = foldl (\s x -> s `c` query q c x) (q i) t 88 | 89 | gsize :: Foldable f => Term f -> Int 90 | gsize = query (const 1) (+) 91 | 92 | -- | This function computes the generic size of the given term, 93 | -- i.e. the its number of subterm occurrences. 94 | size :: Foldable f => Cxt h f a -> Int 95 | size (Hole {}) = 0 96 | size (Term t) = foldl (\s x -> s + size x) 1 t 97 | 98 | -- | This function computes the generic height of the given term. 99 | height :: Foldable f => Cxt h f a -> Int 100 | height (Hole {}) = 0 101 | height (Term t) = 1 + foldl (\s x -> s `max` height x) 0 t 102 | -------------------------------------------------------------------------------- /src/Data/Comp/Mapping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | {-# LANGUAGE DeriveFoldable #-} 8 | -------------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Comp.Mapping 11 | -- Copyright : (c) 2014 Patrick Bahr 12 | -- License : BSD3 13 | -- Maintainer : Patrick Bahr 14 | -- Stability : experimental 15 | -- Portability : non-portable (GHC Extensions) 16 | -- 17 | -- This module provides functionality to construct mappings from 18 | -- positions in a functorial value. 19 | -- 20 | -------------------------------------------------------------------------------- 21 | 22 | module Data.Comp.Mapping 23 | ( Numbered (..) 24 | , unNumbered 25 | , number 26 | , Traversable () 27 | , Mapping (..) 28 | , prodMap 29 | , lookupNumMap 30 | , lookupNumMap' 31 | , NumMap) where 32 | 33 | import Data.IntMap (IntMap) 34 | import qualified Data.IntMap as IntMap 35 | import Data.Traversable 36 | import Data.Foldable 37 | 38 | import Control.Monad.State 39 | import Prelude hiding (mapM) 40 | 41 | 42 | -- | This type is used for numbering components of a functorial value. 43 | data Numbered a = Numbered Int a 44 | 45 | unNumbered :: Numbered a -> a 46 | unNumbered (Numbered _ x) = x 47 | 48 | 49 | -- | This function numbers the components of the given functorial 50 | -- value with consecutive integers starting at 0. 51 | number :: Traversable f => f a -> f (Numbered a) 52 | number x = evalState (mapM run x) 0 where 53 | run b = do n <- get 54 | put (n+1) 55 | return $ Numbered n b 56 | 57 | 58 | infix 1 |-> 59 | infixr 0 & 60 | 61 | 62 | class Functor m => Mapping m k | m -> k where 63 | -- | left-biased union of two mappings. 64 | (&) :: m v -> m v -> m v 65 | 66 | -- | This operator constructs a singleton mapping. 67 | (|->) :: k -> v -> m v 68 | 69 | -- | This is the empty mapping. 70 | empty :: m v 71 | 72 | -- | This function constructs the pointwise product of two maps each 73 | -- with a default value. 74 | prodMapWith :: (v1 -> v2 -> v) -> v1 -> v2 -> m v1 -> m v2 -> m v 75 | 76 | -- | Returns the value at the given key or returns the given 77 | -- default when the key is not an element of the map. 78 | findWithDefault :: a -> k -> m a -> a 79 | 80 | -- | This function constructs the pointwise product of two maps each 81 | -- with a default value. 82 | prodMap :: Mapping m k => v1 -> v2 -> m v1 -> m v2 -> m (v1, v2) 83 | prodMap = prodMapWith (,) 84 | 85 | newtype NumMap k v = NumMap (IntMap v) deriving (Functor,Foldable,Traversable) 86 | 87 | lookupNumMap :: a -> Int -> NumMap t a -> a 88 | lookupNumMap d k (NumMap m) = IntMap.findWithDefault d k m 89 | 90 | lookupNumMap' :: Int -> NumMap t a -> Maybe a 91 | lookupNumMap' k (NumMap m) = IntMap.lookup k m 92 | 93 | instance Mapping (NumMap k) (Numbered k) where 94 | NumMap m1 & NumMap m2 = NumMap (IntMap.union m1 m2) 95 | Numbered k _ |-> v = NumMap $ IntMap.singleton k v 96 | empty = NumMap IntMap.empty 97 | 98 | findWithDefault d (Numbered i _) m = lookupNumMap d i m 99 | 100 | prodMapWith f p q (NumMap mp) (NumMap mq) = NumMap $ IntMap.mergeWithKey merge 101 | (IntMap.map (`f` q)) (IntMap.map (p `f`)) mp mq 102 | where merge _ p q = Just (p `f` q) 103 | -------------------------------------------------------------------------------- /src/Data/Comp/Matching.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.Comp.Matching 7 | -- Copyright : (c) 2010-2011 Patrick Bahr 8 | -- License : BSD3 9 | -- Maintainer : Patrick Bahr 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- This module implements matching of contexts or terms with variables againts terms 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Data.Comp.Matching 18 | ( 19 | matchCxt, 20 | matchTerm, 21 | module Data.Comp.Variables 22 | ) where 23 | 24 | import Data.Comp.Equality 25 | import Data.Comp.Term 26 | import Data.Comp.Variables 27 | import Data.Foldable 28 | import Data.Map (Map) 29 | import qualified Data.Map as Map 30 | import Data.Traversable 31 | 32 | import Prelude hiding (all, mapM, mapM_) 33 | 34 | {-| This is an auxiliary function for implementing 'matchCxt'. It behaves 35 | similarly as 'match' but is oblivious to non-linearity. Therefore, the 36 | substitution that is returned maps holes to non-empty lists of terms 37 | (resp. contexts in general). This substitution is only a matching 38 | substitution if all elements in each list of the substitution's range 39 | are equal. -} 40 | 41 | matchCxt' :: (Ord v, EqF f, Functor f, Foldable f) 42 | => Context f v -> Cxt h f a -> Maybe (Map v [Cxt h f a]) 43 | matchCxt' (Hole v) t = Just $ Map.singleton v [t] 44 | matchCxt' (Term s) (Term t) = do 45 | eqs <- eqMod s t 46 | substs <- mapM (uncurry matchCxt') eqs 47 | return $ Map.unionsWith (++) substs 48 | matchCxt' Term {} Hole {} = Nothing 49 | 50 | 51 | {-| This function takes a context @c@ as the first argument and tries 52 | to match it against the term @t@ (or in general a context with holes 53 | in @a@). The context @c@ matches the term @t@ if there is a 54 | /matching substitution/ @s@ that maps holes to terms (resp. contexts in general) 55 | such that if the holes in the context @c@ are replaced according to 56 | the substitution @s@, the term @t@ is obtained. Note that the context 57 | @c@ might be non-linear, i.e. has multiple holes that are 58 | equal. According to the above definition this means that holes with 59 | equal holes have to be instantiated by equal terms! -} 60 | 61 | matchCxt :: (Ord v,EqF f, Eq (Cxt h f a), Functor f, Foldable f) 62 | => Context f v -> Cxt h f a -> Maybe (CxtSubst h a f v) 63 | matchCxt c1 c2 = do 64 | res <- matchCxt' c1 c2 65 | let insts = Map.elems res 66 | mapM_ checkEq insts 67 | return $ Map.map head res 68 | where checkEq [] = Nothing 69 | checkEq (c : cs) 70 | | all (== c) cs = Just () 71 | | otherwise = Nothing 72 | 73 | {-| This function is similar to 'matchCxt' but instead of a context it 74 | matches a term with variables against a context. -} 75 | 76 | matchTerm :: (Ord v, EqF f, Eq (Cxt h f a) , Traversable f, HasVars f v) 77 | => Term f -> Cxt h f a -> Maybe (CxtSubst h a f v) 78 | matchTerm t = matchCxt (varsToHoles t) 79 | 80 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Annotation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE Rank2Types #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | -------------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Data.Comp.Multi.Annotation 13 | -- Copyright : (c) 2011 Patrick Bahr 14 | -- License : BSD3 15 | -- Maintainer : Patrick Bahr 16 | -- Stability : experimental 17 | -- Portability : non-portable (GHC Extensions) 18 | -- 19 | -- This module defines annotations on signatures. All definitions are 20 | -- generalised versions of those in "Data.Comp.Annotation". 21 | -- 22 | -------------------------------------------------------------------------------- 23 | 24 | module Data.Comp.Multi.Annotation 25 | ( 26 | (:&:) (..), 27 | DistAnn (..), 28 | RemA (..), 29 | liftA, 30 | ann, 31 | liftA', 32 | stripA, 33 | propAnn, 34 | project' 35 | ) where 36 | 37 | import Data.Comp.Multi.Algebra 38 | import Data.Comp.Multi.HFunctor 39 | import Data.Comp.Multi.Ops 40 | import Data.Comp.Multi.Term 41 | import qualified Data.Comp.Ops as O 42 | 43 | -- | This function transforms a function with a domain constructed 44 | -- from a functor to a function with a domain constructed with the 45 | -- same functor but with an additional annotation. 46 | liftA :: (RemA s s') => (s' a :-> t) -> s a :-> t 47 | liftA f v = f (remA v) 48 | 49 | 50 | -- | This function annotates each sub term of the given term with the 51 | -- given value (of type a). 52 | 53 | ann :: (DistAnn f p g, HFunctor f) => p -> CxtFun f g 54 | ann c = appSigFun (injectA c) 55 | 56 | -- | This function transforms a function with a domain constructed 57 | -- from a functor to a function with a domain constructed with the 58 | -- same functor but with an additional annotation. 59 | liftA' :: (DistAnn s' p s, HFunctor s') 60 | => (s' a :-> Cxt h s' a) -> s a :-> Cxt h s a 61 | liftA' f v = let (v' O.:&: p) = projectA v 62 | in ann p (f v') 63 | 64 | {-| This function strips the annotations from a term over a 65 | functor with annotations. -} 66 | 67 | stripA :: (RemA g f, HFunctor g) => CxtFun g f 68 | stripA = appSigFun remA 69 | 70 | 71 | propAnn :: (DistAnn f p f', DistAnn g p g', HFunctor g) 72 | => Hom f g -> Hom f' g' 73 | propAnn alg f' = ann p (alg f) 74 | where (f O.:&: p) = projectA f' 75 | 76 | -- | This function is similar to 'project' but applies to signatures 77 | -- with an annotation which is then ignored. 78 | project' :: (RemA f f', s :<: f') => Cxt h f a i -> Maybe (s (Cxt h f a) i) 79 | project' (Term x) = proj $ remA x 80 | project' _ = Nothing 81 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Multi.Derive 5 | -- Copyright : (c) 2010-2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- This module contains functionality for automatically deriving boilerplate 12 | -- code using Template Haskell. Examples include instances of 'HFunctor', 13 | -- 'HFoldable', and 'HTraversable'. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Data.Comp.Multi.Derive 18 | ( 19 | derive, 20 | -- |Derive boilerplate instances for higher-order signatures, i.e. 21 | -- signatures for generalised compositional data types. 22 | 23 | -- ** HShowF 24 | module Data.Comp.Multi.Derive.Show, 25 | -- ** EqHF 26 | module Data.Comp.Multi.Derive.Equality, 27 | -- ** OrdHF 28 | module Data.Comp.Multi.Derive.Ordering, 29 | -- ** HFunctor 30 | module Data.Comp.Multi.Derive.HFunctor, 31 | -- ** HFoldable 32 | module Data.Comp.Multi.Derive.HFoldable, 33 | -- ** HTraversable 34 | module Data.Comp.Multi.Derive.HTraversable, 35 | -- ** Smart Constructors 36 | module Data.Comp.Multi.Derive.SmartConstructors, 37 | -- ** Smart Constructors w/ Annotations 38 | module Data.Comp.Multi.Derive.SmartAConstructors, 39 | -- ** Lifting to Sums 40 | liftSum 41 | ) where 42 | 43 | import Data.Comp.Derive.Utils (derive, liftSumGen) 44 | import Data.Comp.Multi.Derive.Equality 45 | import Data.Comp.Multi.Derive.HFoldable 46 | import Data.Comp.Multi.Derive.HFunctor 47 | import Data.Comp.Multi.Derive.HTraversable 48 | import Data.Comp.Multi.Derive.Ordering 49 | import Data.Comp.Multi.Derive.Show 50 | import Data.Comp.Multi.Derive.SmartAConstructors 51 | import Data.Comp.Multi.Derive.SmartConstructors 52 | import Data.Comp.Multi.Ops ((:+:), caseH) 53 | 54 | import Language.Haskell.TH 55 | 56 | {-| Given the name of a type class, where the first parameter is a higher-order 57 | functor, lift it to sums of higher-order. Example: @class HShowF f where ...@ 58 | is lifted as @instance (HShowF f, HShowF g) => HShowF (f :+: g) where ... @. 59 | -} 60 | liftSum :: Name -> Q [Dec] 61 | liftSum = liftSumGen 'caseH ''(:+:) 62 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Comp.Multi.Derive.Equality 6 | -- Copyright : (c) 2011 Patrick Bahr 7 | -- License : BSD3 8 | -- Maintainer : Patrick Bahr 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC Extensions) 11 | -- 12 | -- Automatically derive instances of @EqHF@. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | module Data.Comp.Multi.Derive.Equality 16 | ( 17 | EqHF(..), 18 | KEq(..), 19 | makeEqHF 20 | ) where 21 | 22 | import Data.Comp.Derive.Utils 23 | import Data.Comp.Multi.Equality 24 | import Language.Haskell.TH hiding (Cxt, match) 25 | 26 | {-| Derive an instance of 'EqHF' for a type constructor of any higher-order 27 | kind taking at least two arguments. -} 28 | makeEqHF :: Name -> Q [Dec] 29 | makeEqHF fname = do 30 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 31 | let args' = init args 32 | argNames = map (VarT . tyVarBndrName) (init args') 33 | ftyp = VarT . tyVarBndrName $ last args' 34 | complType = foldl AppT (ConT name) argNames 35 | preCond = map (mkClassP ''Eq . (: [])) argNames 36 | classType = AppT (ConT ''EqHF) complType 37 | constrs' <- mapM normalConExp constrs 38 | eqFDecl <- funD 'eqHF (eqFClauses ftyp constrs constrs') 39 | return [mkInstanceD preCond classType [eqFDecl]] 40 | where eqFClauses ftyp constrs constrs' = map (genEqClause ftyp) constrs' 41 | ++ defEqClause constrs 42 | defEqClause constrs 43 | | length constrs < 2 = [] 44 | | otherwise = [clause [wildP,wildP] (normalB [|False|]) []] 45 | genEqClause ftyp (constr, argts, gadtTy) = do 46 | let n = length argts 47 | varNs <- newNames n "x" 48 | varNs' <- newNames n "y" 49 | let pat = ConP constr [] $ map VarP varNs 50 | pat' = ConP constr [] $ map VarP varNs' 51 | vars = map VarE varNs 52 | vars' = map VarE varNs' 53 | mkEq ty x y = let (x',y') = (return x,return y) 54 | in if containsType ty (getBinaryFArg ftyp gadtTy) 55 | then [| $x' `keq` $y'|] 56 | else [| $x' == $y'|] 57 | eqs = listE $ zipWith3 mkEq argts vars vars' 58 | body <- if n == 0 59 | then [|True|] 60 | else [|and $eqs|] 61 | return $ Clause [pat, pat'] (NormalB body) [] 62 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/HFunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Multi.Derive.HFunctor 5 | -- Copyright : (c) 2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive instances of @HFunctor@. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Multi.Derive.HFunctor 16 | ( 17 | HFunctor, 18 | makeHFunctor 19 | ) where 20 | 21 | import Control.Monad 22 | import Data.Comp.Derive.Utils 23 | import Data.Comp.Multi.HFunctor 24 | import Data.Maybe 25 | import Language.Haskell.TH 26 | import Prelude hiding (mapM) 27 | import qualified Prelude as P (mapM) 28 | 29 | iter 0 _ e = e 30 | iter n f e = iter (n-1) f (f `appE` e) 31 | 32 | {-| Derive an instance of 'HFunctor' for a type constructor of any higher-order 33 | kind taking at least two arguments. -} 34 | makeHFunctor :: Name -> Q [Dec] 35 | makeHFunctor fname = do 36 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 37 | let args' = init args 38 | fArg = VarT . tyVarBndrName $ last args' 39 | argNames = map (VarT . tyVarBndrName) (init args') 40 | complType = foldl AppT (ConT name) argNames 41 | classType = AppT (ConT ''HFunctor) complType 42 | constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs 43 | hfmapDecl <- funD 'hfmap (map hfmapClause constrs') 44 | return [mkInstanceD [] classType [hfmapDecl]] 45 | where isFarg fArg (constr, args, ty) = (constr, map (`containsType'` getBinaryFArg fArg ty) args) 46 | filterVar _ nonFarg [] x = nonFarg x 47 | filterVar farg _ [depth] x = farg depth x 48 | filterVar _ _ _ _ = error "functor variable occurring twice in argument type" 49 | filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs 50 | mkCPat constr varNs = ConP constr [] $ map mkPat varNs 51 | mkPat = VarP 52 | mkPatAndVars :: (Name, [[t]]) -> Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool, [Q Exp], [(t, Name)]) 53 | mkPatAndVars (constr, args) = 54 | do varNs <- newNames (length args) "x" 55 | return (conE constr, mkCPat constr varNs, 56 | \ f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE), 57 | any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing)) 58 | hfmapClause (con, pat,vars',hasFargs,_,_) = 59 | do fn <- newName "f" 60 | let f = varE fn 61 | fp = if hasFargs then VarP fn else WildP 62 | vars = vars' (\d x -> iter d [|fmap|] f `appE` x) id 63 | body <- foldl appE con vars 64 | return $ Clause [fp, pat] (NormalB body) [] 65 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/HTraversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Multi.Derive.HTraversable 5 | -- Copyright : (c) 2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive instances of @HTraversable@. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Multi.Derive.HTraversable 16 | ( 17 | HTraversable, 18 | makeHTraversable 19 | ) where 20 | 21 | import Control.Applicative 22 | import Control.Monad hiding (mapM, sequence) 23 | import Data.Comp.Derive.Utils 24 | import Data.Comp.Multi.HTraversable 25 | import Data.Foldable hiding (any, or) 26 | import Data.Maybe 27 | import Data.Traversable 28 | import Language.Haskell.TH 29 | import Prelude hiding (foldl, foldr, mapM, sequence) 30 | import qualified Prelude as P (foldl, foldr, mapM) 31 | 32 | iter 0 _ e = e 33 | iter n f e = iter (n-1) f (f `appE` e) 34 | 35 | 36 | {-| Derive an instance of 'HTraversable' for a type constructor of any 37 | higher-order kind taking at least two arguments. -} 38 | makeHTraversable :: Name -> Q [Dec] 39 | makeHTraversable fname = do 40 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 41 | let args' = init args 42 | fArg = VarT . tyVarBndrName $ last args' 43 | argNames = map (VarT . tyVarBndrName) (init args') 44 | complType = foldl AppT (ConT name) argNames 45 | classType = AppT (ConT ''HTraversable) complType 46 | constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs 47 | traverseDecl <- funD 'htraverse (map traverseClause constrs') 48 | mapMDecl <- funD 'hmapM (map mapMClause constrs') 49 | return [mkInstanceD [] classType [traverseDecl, mapMDecl]] 50 | where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getBinaryFArg fArg gadtTy)) args) 51 | filterVar _ nonFarg [] x = nonFarg x 52 | filterVar farg _ [depth] x = farg depth x 53 | filterVar _ _ _ _ = error "functor variable occurring twice in argument type" 54 | filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs 55 | mkCPat constr varNs = ConP constr [] $ map mkPat varNs 56 | mkPat = VarP 57 | mkPatAndVars (constr, args) = 58 | do varNs <- newNames (length args) "x" 59 | return (conE constr, mkCPat constr varNs, 60 | \f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE), 61 | any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing)) 62 | traverseClause (con, pat,vars',hasFargs,_,_) = 63 | do fn <- newName "f" 64 | let f = varE fn 65 | fp = if hasFargs then VarP fn else WildP 66 | vars = vars' (\d x -> iter d [|traverse|] f `appE` x) (\x -> [|pure $x|]) 67 | body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars 68 | return $ Clause [fp, pat] (NormalB body) [] 69 | -- Note: the monadic versions are not defined 70 | -- applicatively, as this results in a considerable 71 | -- performance penalty (by factor 2)! 72 | mapMClause (con, pat,_,hasFargs,allVars, fvars) = 73 | do fn <- newName "f" 74 | let f = varE fn 75 | fp = if hasFargs then VarP fn else WildP 76 | conAp = P.foldl appE con allVars 77 | conBind (d,x) y = [| $(iter d [|mapM|] f) $(varE x) >>= $(lamE [varP x] y)|] 78 | body <- P.foldr conBind [|return $conAp|] fvars 79 | return $ Clause [fp, pat] (NormalB body) [] 80 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/LiftSum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Comp.Multi.Derive.LiftSum 6 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 7 | -- License : BSD3 8 | -- Maintainer : Tom Hvitved 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC Extensions) 11 | -- 12 | -- Lift a class declaration for higher-order functors to sums of higher-order 13 | -- functors. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | 17 | module Data.Comp.Multi.Derive.LiftSum 18 | ( 19 | liftSum, 20 | caseH 21 | ) where 22 | 23 | import Data.Comp.Derive.Utils 24 | import Data.Comp.Multi.Ops ((:+:) (..)) 25 | import Data.Comp.Multi.Sum 26 | import Language.Haskell.TH hiding (Cxt) 27 | 28 | {-| Given the name of a type class, where the first parameter is a higher-order 29 | functor, lift it to sums of higher-order. Example: @class HShowF f where ...@ 30 | is lifted as @instance (HShowF f, HShowF g) => HShowF (f :+: g) where ... @. 31 | -} 32 | liftSum :: Name -> Q [Dec] 33 | liftSum = liftSumGen 'caseH ''(:+:) 34 | 35 | {-| Utility function to case on a higher-order functor sum, without exposing the 36 | internal representation of sums. -} 37 | caseH :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c 38 | caseH f g x = case x of 39 | Inl x -> f x 40 | Inr x -> g x 41 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/Ordering.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.Comp.Multi.Derive.Ordering 7 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 8 | -- License : BSD3 9 | -- Maintainer : Tom Hvitved 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- Automatically derive instances of @OrdHF@. 14 | -- 15 | -------------------------------------------------------------------------------- 16 | module Data.Comp.Multi.Derive.Ordering 17 | ( 18 | OrdHF(..), 19 | makeOrdHF 20 | ) where 21 | 22 | import Data.Comp.Derive.Utils 23 | import Data.Comp.Multi.Ordering 24 | import Data.List 25 | import Data.Maybe 26 | import Language.Haskell.TH hiding (Cxt) 27 | 28 | compList :: [Ordering] -> Ordering 29 | compList = fromMaybe EQ . find (/= EQ) 30 | 31 | {-| Derive an instance of 'OrdHF' for a type constructor of any parametric 32 | kind taking at least three arguments. -} 33 | makeOrdHF :: Name -> Q [Dec] 34 | makeOrdHF fname = do 35 | Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname 36 | let args' = init args 37 | -- covariant argument 38 | let coArg :: Type = VarT $ tyVarBndrName $ last args' 39 | let argNames = map (VarT . tyVarBndrName) (init args') 40 | let complType = foldl AppT (ConT name) argNames 41 | let classType = AppT (ConT ''OrdHF) complType 42 | constrs' :: [(Name,[Type],Maybe Type)] <- mapM normalConExp constrs 43 | compareHFDecl <- funD 'compareHF (compareHFClauses coArg constrs') 44 | return [mkInstanceD [] classType [compareHFDecl]] 45 | where compareHFClauses :: Type -> [(Name,[Type],Maybe Type)] -> [ClauseQ] 46 | compareHFClauses _ [] = [] 47 | compareHFClauses coArg constrs = 48 | let constrs' = constrs `zip` [1..] 49 | constPairs = [(x,y)| x<-constrs', y <- constrs'] 50 | in map (genClause coArg) constPairs 51 | genClause coArg ((c,n),(d,m)) 52 | | n == m = genEqClause coArg c 53 | | n < m = genLtClause c d 54 | | otherwise = genGtClause c d 55 | genEqClause :: Type -> (Name,[Type],Maybe Type) -> ClauseQ 56 | genEqClause coArg (constr, args,gadtTy) = do 57 | varXs <- newNames (length args) "x" 58 | varYs <- newNames (length args) "y" 59 | let patX = ConP constr [] $ map VarP varXs 60 | let patY = ConP constr [] $ map VarP varYs 61 | body <- eqDBody (getBinaryFArg coArg gadtTy) (zip3 varXs varYs args) 62 | return $ Clause [patX, patY] (NormalB body) [] 63 | eqDBody :: Type -> [(Name, Name, Type)] -> ExpQ 64 | eqDBody coArg x = 65 | [|compList $(listE $ map (eqDB coArg) x)|] 66 | eqDB :: Type -> (Name, Name, Type) -> ExpQ 67 | eqDB coArg (x, y, tp) 68 | | not (containsType tp coArg) = 69 | [| compare $(varE x) $(varE y) |] 70 | | otherwise = 71 | [| kcompare $(varE x) $(varE y) |] 72 | genLtClause (c, _, _) (d, _, _) = 73 | clause [recP c [], recP d []] (normalB [| LT |]) [] 74 | genGtClause (c, _, _) (d, _, _) = 75 | clause [recP c [], recP d []] (normalB [| GT |]) [] 76 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | -------------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.Comp.Multi.Derive.Show 6 | -- Copyright : (c) 2011 Patrick Bahr 7 | -- License : BSD3 8 | -- Maintainer : Patrick Bahr 9 | -- Stability : experimental 10 | -- Portability : non-portable (GHC Extensions) 11 | -- 12 | -- Automatically derive instances of @ShowHF@. 13 | -- 14 | -------------------------------------------------------------------------------- 15 | 16 | module Data.Comp.Multi.Derive.Show 17 | ( 18 | ShowHF(..), 19 | KShow(..), 20 | makeShowHF 21 | ) where 22 | 23 | import Data.Comp.Derive.Utils 24 | import Data.Comp.Multi.Algebra 25 | import Data.Comp.Multi.HFunctor 26 | import Language.Haskell.TH 27 | 28 | {-| Signature printing. An instance @ShowHF f@ gives rise to an instance 29 | @KShow (HTerm f)@. -} 30 | class ShowHF f where 31 | showHF :: Alg f (K String) 32 | showHF = K . showHF' 33 | showHF' :: f (K String) :=> String 34 | showHF' = unK . showHF 35 | 36 | class KShow a where 37 | kshow :: a i -> K String i 38 | 39 | showConstr :: String -> [String] -> String 40 | showConstr con [] = con 41 | showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")" 42 | 43 | {-| Derive an instance of 'ShowHF' for a type constructor of any higher-order 44 | kind taking at least two arguments. -} 45 | makeShowHF :: Name -> Q [Dec] 46 | makeShowHF fname = do 47 | Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname 48 | let args' = init args 49 | fArg = VarT . tyVarBndrName $ last args' 50 | argNames = map (VarT . tyVarBndrName) (init args') 51 | complType = foldl AppT (ConT name) argNames 52 | preCond = map (mkClassP ''Show . (: [])) argNames 53 | classType = AppT (ConT ''ShowHF) complType 54 | constrs' <- mapM normalConExp constrs 55 | showFDecl <- funD 'showHF (showFClauses fArg constrs') 56 | return [mkInstanceD preCond classType [showFDecl]] 57 | where showFClauses fArg = map (genShowFClause fArg) 58 | filterFarg fArg ty x = (containsType ty fArg, varE x) 59 | mkShow (isFArg, var) 60 | | isFArg = [|unK $var|] 61 | | otherwise = [| show $var |] 62 | genShowFClause fArg (constr, args, ty) = do 63 | let n = length args 64 | varNs <- newNames n "x" 65 | let pat = ConP constr [] $ map VarP varNs 66 | allVars = zipWith (filterFarg (getBinaryFArg fArg ty)) args varNs 67 | shows = listE $ map mkShow allVars 68 | conName = nameBase constr 69 | body <- [|K $ showConstr conName $shows|] 70 | return $ Clause [pat] (NormalB body) [] 71 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/SmartAConstructors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Multi.Derive.SmartAConstructors 5 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 6 | -- License : BSD3 7 | -- Maintainer : Tom Hvitved 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive smart constructors with annotations. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Multi.Derive.SmartAConstructors 16 | ( 17 | smartAConstructors 18 | ) where 19 | 20 | import Control.Monad 21 | import Data.Comp.Derive.Utils 22 | import Data.Comp.Multi.Annotation 23 | import Data.Comp.Multi.Sum 24 | import Data.Comp.Multi.Term 25 | import Language.Haskell.TH hiding (Cxt) 26 | 27 | {-| Derive smart constructors with products for a type constructor of any 28 | parametric kind taking at least two arguments. The smart constructors are 29 | similar to the ordinary constructors, but an 'injectA' is automatically 30 | inserted. -} 31 | smartAConstructors :: Name -> Q [Dec] 32 | smartAConstructors fname = do 33 | Just (DataInfo _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname 34 | let cons = map abstractConType constrs 35 | liftM concat $ mapM genSmartConstr cons 36 | where genSmartConstr (name, args) = do 37 | let bname = nameBase name 38 | genSmartConstr' (mkName $ "iA" ++ bname) name args 39 | genSmartConstr' sname name args = do 40 | varNs <- newNames args "x" 41 | varPr <- newName "_p" 42 | let pats = map varP (varPr : varNs) 43 | vars = map varE varNs 44 | val = appE [|injectA $(varE varPr)|] $ 45 | appE [|inj|] $ foldl appE (conE name) vars 46 | function = [funD sname [clause pats (normalB [|Term $val|]) []]] 47 | sequence function 48 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Derive/SmartConstructors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -------------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Comp.Multi.Derive.SmartConstructors 5 | -- Copyright : (c) 2011 Patrick Bahr 6 | -- License : BSD3 7 | -- Maintainer : Patrick Bahr 8 | -- Stability : experimental 9 | -- Portability : non-portable (GHC Extensions) 10 | -- 11 | -- Automatically derive smart constructors for mutually recursive types. 12 | -- 13 | -------------------------------------------------------------------------------- 14 | 15 | module Data.Comp.Multi.Derive.SmartConstructors 16 | ( 17 | smartConstructors 18 | ) where 19 | 20 | import Control.Arrow ((&&&)) 21 | import Control.Monad 22 | import Data.Comp.Derive.Utils 23 | import Data.Comp.Multi.Sum 24 | import Data.Comp.Multi.Term 25 | import Language.Haskell.TH hiding (Cxt) 26 | 27 | {-| Derive smart constructors for a type constructor of any higher-order kind 28 | taking at least two arguments. The smart constructors are similar to the 29 | ordinary constructors, but an 'inject' is automatically inserted. -} 30 | smartConstructors :: Name -> Q [Dec] 31 | smartConstructors fname = do 32 | Just (DataInfo _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname 33 | let iVar = tyVarBndrName $ last targs 34 | let cons = map (abstractConType &&& iTp iVar) constrs 35 | liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons 36 | where iTp iVar (ForallC _ cxt _) = 37 | -- Check if the GADT phantom type is constrained 38 | case [y | Just (x, y) <- map isEqualP cxt, x == VarT iVar] of 39 | [] -> Nothing 40 | tp:_ -> Just tp 41 | iTp _ _ = Nothing 42 | genSmartConstr targs tname ((name, args), miTp) = do 43 | let bname = nameBase name 44 | genSmartConstr' targs tname (mkName $ 'i' : bname) name args miTp 45 | genSmartConstr' targs tname sname name args miTp = do 46 | varNs <- newNames args "x" 47 | let pats = map varP varNs 48 | vars = map varE varNs 49 | val = foldl appE (conE name) vars 50 | sig = genSig targs tname sname args miTp 51 | function = [funD sname [clause pats (normalB [|inject $val|]) []]] 52 | sequence $ sig ++ function 53 | genSig targs tname sname 0 miTp = (:[]) $ do 54 | fvar <- newName "f" 55 | hvar <- newName "h" 56 | avar <- newName "a" 57 | ivar <- newName "i" 58 | let targs' = init $ init targs 59 | vars = hvar:fvar:avar:maybe [ivar] (const []) miTp++targs' 60 | f = varT fvar 61 | h = varT hvar 62 | a = varT avar 63 | i = varT ivar 64 | ftype = foldl appT (conT tname) (map varT targs') 65 | constr = (conT ''(:<:) `appT` ftype) `appT` f 66 | typ = foldl appT (conT ''Cxt) [h, f, a, maybe i return miTp] 67 | typeSig = forallT (map (\ v -> PlainTV v SpecifiedSpec) vars) (sequence [constr]) typ 68 | sigD sname typeSig 69 | genSig _ _ _ _ _ = [] 70 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | -------------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Comp.Multi.Desugar 9 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 10 | -- License : BSD3 11 | -- Maintainer : Tom Hvitved 12 | -- Stability : experimental 13 | -- Portability : non-portable (GHC Extensions) 14 | -- 15 | -- This modules defines the 'Desugar' type class for desugaring of terms. 16 | -- 17 | -------------------------------------------------------------------------------- 18 | 19 | module Data.Comp.Multi.Desugar where 20 | 21 | import Data.Comp.Multi 22 | 23 | 24 | -- |The desugaring term homomorphism. 25 | class (HFunctor f, HFunctor g) => Desugar f g where 26 | desugHom :: Hom f g 27 | desugHom = desugHom' . hfmap Hole 28 | desugHom' :: Alg f (Context g a) 29 | desugHom' x = appCxt (desugHom x) 30 | 31 | 32 | -- We make the lifting to sums explicit in order to make the Desugar 33 | -- class work with the default instance declaration further below. 34 | instance {-# OVERLAPPABLE #-} (Desugar f h, Desugar g h) => Desugar (f :+: g) h where 35 | desugHom = caseH desugHom desugHom 36 | 37 | -- |Desugar a term. 38 | desugar :: Desugar f g => Term f :-> Term g 39 | desugar = appHom desugHom 40 | 41 | -- |Lift desugaring to annotated terms. 42 | desugarA :: (HFunctor f', HFunctor g', DistAnn f p f', DistAnn g p g', 43 | Desugar f g) => Term f' :-> Term g' 44 | desugarA = appHom (propAnn desugHom) 45 | 46 | -- |Default desugaring instance. 47 | instance {-# OVERLAPPABLE #-} (HFunctor f, HFunctor g, f :<: g) => Desugar f g where 48 | desugHom = simpCxt . inj 49 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Equality.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.Comp.Multi.Equality 7 | -- Copyright : (c) Patrick Bahr, 2011 8 | -- License : BSD3 9 | -- Maintainer : Patrick Bahr 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- This module defines equality for (higher-order) signatures, which lifts to 14 | -- equality for (higher-order) terms and contexts. All definitions are 15 | -- generalised versions of those in "Data.Comp.Equality". 16 | -- 17 | -------------------------------------------------------------------------------- 18 | module Data.Comp.Multi.Equality 19 | ( 20 | EqHF(..), 21 | KEq(..), 22 | heqMod 23 | ) where 24 | 25 | import Data.Comp.Multi.HFoldable 26 | import Data.Comp.Multi.HFunctor 27 | import Data.Comp.Multi.Ops 28 | import Data.Comp.Multi.Term 29 | 30 | class KEq f where 31 | keq :: f i -> f j -> Bool 32 | 33 | {-| Signature equality. An instance @EqHF f@ gives rise to an instance 34 | @KEq (HTerm f)@. -} 35 | class EqHF f where 36 | eqHF :: KEq g => f g i -> f g j -> Bool 37 | 38 | instance Eq a => KEq (K a) where 39 | keq (K x) (K y) = x == y 40 | 41 | instance KEq a => Eq (E a) where 42 | E x == E y = x `keq` y 43 | 44 | {-| 45 | 'EqF' is propagated through sums. 46 | -} 47 | instance (EqHF f, EqHF g) => EqHF (f :+: g) where 48 | eqHF (Inl x) (Inl y) = eqHF x y 49 | eqHF (Inr x) (Inr y) = eqHF x y 50 | eqHF _ _ = False 51 | 52 | instance EqHF f => EqHF (Cxt h f) where 53 | eqHF (Term e1) (Term e2) = e1 `eqHF` e2 54 | eqHF (Hole h1) (Hole h2) = h1 `keq` h2 55 | eqHF _ _ = False 56 | 57 | instance (EqHF f, KEq a) => KEq (Cxt h f a) where 58 | keq = eqHF 59 | 60 | {-| 61 | From an 'EqF' functor an 'Eq' instance of the corresponding 62 | term type can be derived. 63 | -} 64 | instance (EqHF f, KEq a) => Eq (Cxt h f a i) where 65 | (==) = keq 66 | 67 | {-| This function implements equality of values of type @f a@ modulo 68 | the equality of @a@ itself. If two functorial values are equal in this 69 | sense, 'eqMod' returns a 'Just' value containing a list of pairs 70 | consisting of corresponding components of the two functorial 71 | values. -} 72 | 73 | heqMod :: (EqHF f, HFunctor f, HFoldable f) => f a i -> f b i -> Maybe [(E a, E b)] 74 | heqMod s t 75 | | unit s `eqHF` unit' t = Just args 76 | | otherwise = Nothing 77 | where unit = hfmap (const $ K ()) 78 | unit' = hfmap (const $ K ()) 79 | args = htoList s `zip` htoList t 80 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | -------------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.Comp.Multi.Generic 12 | -- Copyright : (c) 2011 Patrick Bahr 13 | -- License : BSD3 14 | -- Maintainer : Patrick Bahr 15 | -- Stability : experimental 16 | -- Portability : non-portable (GHC Extensions) 17 | -- 18 | -- This module defines type generic functions and recursive schemes 19 | -- along the lines of the Uniplate library. All definitions are 20 | -- generalised versions of those in "Data.Comp.Generic". 21 | -- 22 | -------------------------------------------------------------------------------- 23 | 24 | module Data.Comp.Multi.Generic where 25 | 26 | import Control.Monad 27 | import Data.Comp.Multi.HFoldable 28 | import Data.Comp.Multi.HFunctor 29 | import Data.Comp.Multi.HTraversable 30 | import Data.Comp.Multi.Sum 31 | import Data.Comp.Multi.Term 32 | import GHC.Exts 33 | import Prelude 34 | 35 | import Data.Maybe 36 | 37 | -- | This function returns a list of all subterms of the given 38 | -- term. This function is similar to Uniplate's @universe@ function. 39 | subterms :: forall f . HFoldable f => Term f :=> [E (Term f)] 40 | subterms t = build (f t) 41 | where f :: forall i b. Term f i -> (E (Term f) -> b -> b) -> b -> b 42 | f t cons nil = E t `cons` hfoldl (\u s -> f s cons u) nil (unTerm t) 43 | 44 | -- | This function returns a list of all subterms of the given term 45 | -- that are constructed from a particular functor. 46 | subterms' :: forall f g . (HFoldable f, g :<: f) => Term f :=> [E (g (Term f))] 47 | subterms' (Term t) = build (f t) 48 | where f :: forall i b. f (Term f) i -> (E (g (Term f)) -> b -> b) -> b -> b 49 | f t cons nil = let rest = hfoldl (\u (Term s) -> f s cons u) nil t 50 | in case proj t of 51 | Just t' -> E t' `cons` rest 52 | Nothing -> rest 53 | 54 | -- | This function transforms every subterm according to the given 55 | -- function in a bottom-up manner. This function is similar to 56 | -- Uniplate's @transform@ function. 57 | transform :: forall f . (HFunctor f) => (Term f :-> Term f) -> Term f :-> Term f 58 | transform f = run 59 | where run :: Term f :-> Term f 60 | run = f . Term . hfmap run . unTerm 61 | 62 | 63 | -- | Monadic version of 'transform'. 64 | transformM :: forall f m . (HTraversable f, Monad m) => 65 | NatM m (Term f) (Term f) -> NatM m (Term f) (Term f) 66 | transformM f = run 67 | where run :: NatM m (Term f) (Term f) 68 | run t = f =<< liftM Term (hmapM run $ unTerm t) 69 | 70 | query :: HFoldable f => (Term f :=> r) -> (r -> r -> r) -> Term f :=> r 71 | -- query q c = run 72 | -- where run i@(Term t) = foldl (\s x -> s `c` run x) (q i) t 73 | query q c i@(Term t) = hfoldl (\s x -> s `c` query q c x) (q i) t 74 | 75 | subs :: HFoldable f => Term f :=> [E (Term f)] 76 | subs = query (\x-> [E x]) (++) 77 | 78 | subs' :: (HFoldable f, g :<: f) => Term f :=> [E (g (Term f))] 79 | subs' = mapMaybe pr . subs 80 | where pr (E v) = fmap E (project v) 81 | 82 | -- | This function computes the generic size of the given term, 83 | -- i.e. the its number of subterm occurrences. 84 | size :: HFoldable f => Cxt h f a :=> Int 85 | size (Hole {}) = 0 86 | size (Term t) = hfoldl (\s x -> s + size x) 1 t 87 | 88 | -- | This function computes the generic depth of the given term. 89 | depth :: HFoldable f => Cxt h f a :=> Int 90 | depth (Hole {}) = 0 91 | depth (Term t) = 1 + hfoldl (\s x -> s `max` depth x) 0 t 92 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/HFoldable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | -------------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.Comp.Multi.HFoldable 12 | -- Copyright : (c) 2011 Patrick Bahr 13 | -- License : BSD3 14 | -- Maintainer : Patrick Bahr 15 | -- Stability : experimental 16 | -- Portability : non-portable (GHC Extensions) 17 | -- 18 | -- This module defines higher-order foldable functors. 19 | -- 20 | -------------------------------------------------------------------------------- 21 | 22 | module Data.Comp.Multi.HFoldable 23 | ( 24 | HFoldable (..), 25 | kfoldr, 26 | kfoldl, 27 | htoList 28 | ) where 29 | 30 | import Data.Comp.Multi.HFunctor 31 | import Data.Maybe 32 | import Data.Monoid 33 | 34 | -- | Higher-order functors that can be folded. 35 | -- 36 | -- Minimal complete definition: 'hfoldMap' or 'hfoldr'. 37 | class HFunctor h => HFoldable h where 38 | hfold :: Monoid m => h (K m) :=> m 39 | hfold = hfoldMap unK 40 | 41 | hfoldMap :: Monoid m => (a :=> m) -> h a :=> m 42 | hfoldMap f = hfoldr (mappend . f) mempty 43 | 44 | hfoldr :: (a :=> (b->b) ) -> b -> h a :=> b 45 | hfoldr f z t = appEndo (hfoldMap (Endo . f) t) z 46 | 47 | hfoldl :: (b -> a :=> b) -> b -> h a :=> b 48 | hfoldl f z t = appEndo (getDual (hfoldMap (Dual . Endo . flip f) t)) z 49 | 50 | 51 | hfoldr1 :: forall a. (a -> a -> a) -> h (K a) :=> a 52 | hfoldr1 f xs = fromMaybe (error "hfoldr1: empty structure") 53 | (hfoldr mf Nothing xs) 54 | where mf :: K a :=> (Maybe a -> Maybe a) 55 | mf (K x) Nothing = Just x 56 | mf (K x) (Just y) = Just (f x y) 57 | 58 | hfoldl1 :: forall a . (a -> a -> a) -> h (K a) :=> a 59 | hfoldl1 f xs = fromMaybe (error "hfoldl1: empty structure") 60 | (hfoldl mf Nothing xs) 61 | where mf :: Maybe a -> K a :=> Maybe a 62 | mf Nothing (K y) = Just y 63 | mf (Just x) (K y) = Just (f x y) 64 | 65 | htoList :: (HFoldable f) => f a :=> [E a] 66 | htoList = hfoldr (\ n l -> E n : l) [] 67 | 68 | kfoldr :: (HFoldable f) => (a -> b -> b) -> b -> f (K a) :=> b 69 | kfoldr f = hfoldr (\ (K x) y -> f x y) 70 | 71 | 72 | kfoldl :: (HFoldable f) => (b -> a -> b) -> b -> f (K a) :=> b 73 | kfoldl f = hfoldl (\ x (K y) -> f x y) 74 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/HFunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE DeriveFoldable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE Rank2Types #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE IncoherentInstances #-} 13 | 14 | -------------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Data.Comp.Multi.HFunctor 17 | -- Copyright : (c) 2011 Patrick Bahr 18 | -- License : BSD3 19 | -- Maintainer : Patrick Bahr 20 | -- Stability : experimental 21 | -- Portability : non-portable (GHC Extensions) 22 | -- 23 | -- This module defines higher-order functors (Johann, Ghani, POPL 24 | -- '08), i.e. endofunctors on the category of endofunctors. 25 | -- 26 | -------------------------------------------------------------------------------- 27 | 28 | module Data.Comp.Multi.HFunctor 29 | ( 30 | HFunctor (..), 31 | (:->), 32 | (:=>), 33 | NatM, 34 | I (..), 35 | K (..), 36 | A (..), 37 | E (..), 38 | runE, 39 | (:.:)(..) 40 | ) where 41 | 42 | import Data.Functor.Compose 43 | import Data.Kind 44 | 45 | -- | The identity Functor. 46 | newtype I a = I {unI :: a} deriving (Functor, Foldable, Traversable) 47 | 48 | 49 | -- | The parametrised constant functor. 50 | newtype K a i = K {unK :: a} deriving (Functor, Foldable, Traversable) 51 | 52 | data E f = forall i. E {unE :: f i} 53 | 54 | runE :: (f :=> b) -> E f -> b 55 | runE f (E x) = f x 56 | 57 | data A f = A {unA :: forall i. f i} 58 | 59 | instance Eq a => Eq (K a i) where 60 | K x == K y = x == y 61 | K x /= K y = x /= y 62 | 63 | instance Ord a => Ord (K a i) where 64 | K x < K y = x < y 65 | K x > K y = x > y 66 | K x <= K y = x <= y 67 | K x >= K y = x >= y 68 | min (K x) (K y) = K $ min x y 69 | max (K x) (K y) = K $ max x y 70 | compare (K x) (K y) = compare x y 71 | 72 | 73 | infixr 0 :-> -- same precedence as function space operator -> 74 | infixr 0 :=> -- same precedence as function space operator -> 75 | 76 | -- | This type represents natural transformations. 77 | type f :-> g = forall i . f i -> g i 78 | 79 | -- | This type represents co-cones from @f@ to @a@. @f :=> a@ is 80 | -- isomorphic to f :-> K a 81 | type f :=> a = forall i . f i -> a 82 | 83 | 84 | type NatM m f g = forall i. f i -> m (g i) 85 | 86 | -- | This class represents higher-order functors (Johann, Ghani, POPL 87 | -- '08) which are endofunctors on the category of endofunctors. 88 | class HFunctor h where 89 | -- A higher-order functor @f@ maps every functor @g@ to a 90 | -- functor @f g@. 91 | -- 92 | -- @ffmap :: (Functor g) => (a -> b) -> f g a -> f g b@ 93 | -- 94 | -- We omit this, as it does not work for GADTs (see Johand and 95 | -- Ghani 2008). 96 | 97 | -- | A higher-order functor @f@ also maps a natural transformation 98 | -- @g :-> h@ to a natural transformation @f g :-> f h@ 99 | hfmap :: (f :-> g) -> h f :-> h g 100 | 101 | instance (Functor f) => HFunctor (Compose f) where hfmap f (Compose xs) = Compose (fmap f xs) 102 | 103 | infixl 5 :.: 104 | 105 | -- | This data type denotes the composition of two functor families. 106 | data (:.:) f (g :: (Type -> Type) -> (Type -> Type)) (e :: Type -> Type) t = Comp (f (g e) t) 107 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/HTraversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | -------------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Data.Comp.Multi.HTraversable 12 | -- Copyright : (c) 2011 Patrick Bahr 13 | -- License : BSD3 14 | -- Maintainer : Patrick Bahr 15 | -- Stability : experimental 16 | -- Portability : non-portable (GHC Extensions) 17 | -- 18 | -- This module defines higher-order traversable functors. 19 | -- 20 | -------------------------------------------------------------------------------- 21 | 22 | module Data.Comp.Multi.HTraversable 23 | ( 24 | HTraversable (..) 25 | ) where 26 | 27 | 28 | import Data.Comp.Multi.HFoldable 29 | import Data.Comp.Multi.HFunctor 30 | 31 | class HFoldable t => HTraversable t where 32 | 33 | -- | Map each element of a structure to a monadic action, evaluate 34 | -- these actions from left to right, and collect the results. 35 | -- 36 | -- Alternative type in terms of natural transformations using 37 | -- functor composition @:.:@: 38 | -- 39 | -- @ 40 | -- hmapM :: Monad m => (a :-> m :.: b) -> t a :-> m :.: (t b) 41 | -- @ 42 | -- 43 | hmapM :: (Monad m) => NatM m a b -> NatM m (t a) (t b) 44 | 45 | htraverse :: (Applicative f) => NatM f a b -> NatM f (t a) (t b) 46 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Mapping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TupleSections #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | -------------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Data.Comp.Multi.Mapping 11 | -- Copyright : (c) 2014 Patrick Bahr 12 | -- License : BSD3 13 | -- Maintainer : Patrick Bahr 14 | -- Stability : experimental 15 | -- Portability : non-portable (GHC Extensions) 16 | -- 17 | -- This module provides functionality to construct mappings from 18 | -- positions in a functorial value. 19 | -- 20 | -------------------------------------------------------------------------------- 21 | 22 | module Data.Comp.Multi.Mapping 23 | ( Numbered (..) 24 | , unNumbered 25 | , number 26 | , HTraversable () 27 | , Mapping (..) 28 | , lookupNumMap) where 29 | 30 | import Data.Comp.Multi.HFunctor 31 | import Data.Comp.Multi.HTraversable 32 | 33 | import Data.Kind 34 | 35 | import Control.Monad.State 36 | 37 | import Data.IntMap (IntMap) 38 | import qualified Data.IntMap as IntMap 39 | 40 | 41 | -- | This type is used for numbering components of a functorial value. 42 | data Numbered a i = Numbered Int (a i) 43 | 44 | unNumbered :: Numbered a :-> a 45 | unNumbered (Numbered _ x) = x 46 | 47 | 48 | -- | This function numbers the components of the given functorial 49 | -- value with consecutive integers starting at 0. 50 | number :: HTraversable f => f a :-> f (Numbered a) 51 | number x = evalState (hmapM run x) 0 where 52 | run b = do n <- get 53 | put (n+1) 54 | return $ Numbered n b 55 | 56 | 57 | 58 | infix 1 |-> 59 | infixr 0 & 60 | 61 | 62 | class Mapping m (k :: Type -> Type) | m -> k where 63 | -- | left-biased union of two mappings. 64 | (&) :: m v -> m v -> m v 65 | 66 | -- | This operator constructs a singleton mapping. 67 | (|->) :: k i -> v -> m v 68 | 69 | -- | This is the empty mapping. 70 | empty :: m v 71 | 72 | -- | This function constructs the pointwise product of two maps each 73 | -- with a default value. 74 | prodMap :: v1 -> v2 -> m v1 -> m v2 -> m (v1, v2) 75 | 76 | -- | Returns the value at the given key or returns the given 77 | -- default when the key is not an element of the map. 78 | findWithDefault :: a -> k i -> m a -> a 79 | 80 | 81 | newtype NumMap (k :: Type -> Type) v = NumMap (IntMap v) deriving Functor 82 | 83 | lookupNumMap :: a -> Int -> NumMap t a -> a 84 | lookupNumMap d k (NumMap m) = IntMap.findWithDefault d k m 85 | 86 | instance Mapping (NumMap k) (Numbered k) where 87 | NumMap m1 & NumMap m2 = NumMap (IntMap.union m1 m2) 88 | Numbered k _ |-> v = NumMap $ IntMap.singleton k v 89 | empty = NumMap IntMap.empty 90 | 91 | findWithDefault d (Numbered i _) m = lookupNumMap d i m 92 | 93 | prodMap p q (NumMap mp) (NumMap mq) = NumMap $ IntMap.mergeWithKey merge 94 | (IntMap.map (,q)) (IntMap.map (p,)) mp mq 95 | where merge _ p q = Just (p,q) 96 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Ordering.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | -------------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Data.Comp.Multi.Ordering 9 | -- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved 10 | -- License : BSD3 11 | -- Maintainer : Tom Hvitved 12 | -- Stability : experimental 13 | -- Portability : non-portable (GHC Extensions) 14 | -- 15 | -- This module defines ordering of signatures, which lifts to ordering of 16 | -- terms and contexts. 17 | -- 18 | -------------------------------------------------------------------------------- 19 | module Data.Comp.Multi.Ordering 20 | ( 21 | KOrd(..), 22 | OrdHF(..) 23 | ) where 24 | 25 | import Data.Comp.Multi.Equality 26 | import Data.Comp.Multi.HFunctor 27 | import Data.Comp.Multi.Ops 28 | import Data.Comp.Multi.Term 29 | 30 | class KEq f => KOrd f where 31 | kcompare :: f i -> f j -> Ordering 32 | 33 | {-| Signature ordering. An instance @OrdHF f@ gives rise to an instance 34 | @Ord (Term f)@. -} 35 | class EqHF f => OrdHF f where 36 | compareHF :: KOrd a => f a i -> f a j -> Ordering 37 | 38 | instance KOrd f => Ord (E f) where 39 | compare (E x) (E y) = kcompare x y 40 | 41 | instance Ord a => KOrd (K a) where 42 | kcompare (K x) (K y) = compare x y 43 | 44 | {-| 'OrdHF' is propagated through sums. -} 45 | instance (OrdHF f, OrdHF g) => OrdHF (f :+: g) where 46 | compareHF (Inl x) (Inl y) = compareHF x y 47 | compareHF (Inl _) (Inr _) = LT 48 | compareHF (Inr x) (Inr y) = compareHF x y 49 | compareHF (Inr _) (Inl _) = GT 50 | 51 | {-| From an 'OrdHF' difunctor an 'Ord' instance of the corresponding term type 52 | can be derived. -} 53 | instance (HFunctor f, OrdHF f) => OrdHF (Cxt h f) where 54 | compareHF (Term e1) (Term e2) = compareHF e1 e2 55 | compareHF (Hole h1) (Hole h2) = kcompare h1 h2 56 | compareHF (Term _) _ = LT 57 | compareHF (Hole _) (Term _) = GT 58 | 59 | instance (HFunctor f, OrdHF f, KOrd a) => KOrd (Cxt h f a) where 60 | kcompare = compareHF 61 | 62 | {-| Ordering of terms. -} 63 | instance (HFunctor f, OrdHF f, KOrd a) => Ord (Cxt h f a i) where 64 | compare = kcompare 65 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Projection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Data.Comp.Multi.Projection 17 | -- Copyright : (c) 2014 Patrick Bahr 18 | -- License : BSD3 19 | -- Maintainer : Patrick Bahr 20 | -- Stability : experimental 21 | -- Portability : non-portable (GHC Extensions) 22 | -- 23 | -- This module provides a generic projection function 'pr' for 24 | -- arbitrary nested binary products. 25 | -- 26 | -------------------------------------------------------------------------------- 27 | 28 | 29 | module Data.Comp.Multi.Projection (pr, (:<), (:*:)(..), ffst, fsnd) where 30 | 31 | import Data.Comp.SubsumeCommon 32 | import Data.Comp.Multi.Ops hiding (Elem) 33 | 34 | import Data.Kind 35 | 36 | type family Elem (f :: Type -> Type) 37 | (g :: Type -> Type) :: Emb where 38 | Elem f f = Found Here 39 | Elem (f1 :*: f2) g = Sum' (Elem f1 g) (Elem f2 g) 40 | Elem f (g1 :*: g2) = Choose (Elem f g1) (Elem f g2) 41 | Elem f g = NotFound 42 | 43 | class Proj (e :: Emb) (p :: Type -> Type) 44 | (q :: Type -> Type) where 45 | pr' :: Proxy e -> q a -> p a 46 | 47 | instance Proj (Found Here) f f where 48 | pr' _ = id 49 | 50 | instance Proj (Found p) f g => Proj (Found (Le p)) f (g :*: g') where 51 | pr' _ = pr' (P :: Proxy (Found p)) . ffst 52 | 53 | 54 | instance Proj (Found p) f g => Proj (Found (Ri p)) f (g' :*: g) where 55 | pr' _ = pr' (P :: Proxy (Found p)) . fsnd 56 | 57 | 58 | instance (Proj (Found p1) f1 g, Proj (Found p2) f2 g) 59 | => Proj (Found (Sum p1 p2)) (f1 :*: f2) g where 60 | pr' _ x = (pr' (P :: Proxy (Found p1)) x :*: pr' (P :: Proxy (Found p2)) x) 61 | 62 | 63 | infixl 5 :< 64 | 65 | -- | The constraint @e :< p@ expresses that @e@ is a component of the 66 | -- type @p@. That is, @p@ is formed by binary products using the type 67 | -- @e@. The occurrence of @e@ must be unique. For example we have @Int 68 | -- :< (Bool,(Int,Bool))@ but not @Bool :< (Bool,(Int,Bool))@. 69 | 70 | type f :< g = (Proj (ComprEmb (Elem f g)) f g) 71 | 72 | 73 | -- | This function projects the component of type @e@ out or the 74 | -- compound value of type @p@. 75 | 76 | pr :: forall p q a . (p :< q) => q a -> p a 77 | pr = pr' (P :: Proxy (ComprEmb (Elem p q))) 78 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Comp.Multi.Show 10 | -- Copyright : (c) 2011 Patrick Bahr 11 | -- License : BSD3 12 | -- Maintainer : Patrick Bahr 13 | -- Stability : experimental 14 | -- Portability : non-portable (GHC Extensions) 15 | -- 16 | -- This module defines showing of (higher-order) signatures, which lifts to 17 | -- showing of (higher-order) terms and contexts. All definitions are 18 | -- generalised versions of those in "Data.Comp.Show". 19 | -- 20 | -------------------------------------------------------------------------------- 21 | 22 | module Data.Comp.Multi.Show 23 | ( ShowHF(..) 24 | ) where 25 | 26 | import Data.Comp.Multi.Algebra 27 | import Data.Comp.Multi.Annotation 28 | import Data.Comp.Multi.Derive 29 | import Data.Comp.Multi.HFunctor 30 | import Data.Comp.Multi.Term 31 | 32 | instance KShow (K String) where 33 | kshow = id 34 | 35 | instance KShow (K ()) where 36 | kshow _ = K $ show () 37 | 38 | instance (ShowHF f, HFunctor f) => ShowHF (Cxt h f) where 39 | showHF (Hole s) = s 40 | showHF (Term t) = showHF $ hfmap showHF t 41 | 42 | instance (ShowHF f, HFunctor f, KShow a) => KShow (Cxt h f a) where 43 | kshow = free showHF kshow 44 | 45 | instance (KShow (Cxt h f a)) => Show (Cxt h f a i) where 46 | show = unK . kshow 47 | 48 | instance (ShowHF f, Show p) => ShowHF (f :&: p) where 49 | showHF (v :&: p) = K $ unK (showHF v) ++ " :&: " ++ show p 50 | 51 | $(derive [liftSum] [''ShowHF]) 52 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Sum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE Rank2Types #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Comp.Multi.Sum 10 | -- Copyright : (c) 2011 Patrick Bahr 11 | -- License : BSD3 12 | -- Maintainer : Patrick Bahr 13 | -- Stability : experimental 14 | -- Portability : non-portable (GHC Extensions) 15 | -- 16 | -- This module defines sums on signatures. All definitions are 17 | -- generalised versions of those in "Data.Comp.Sum". 18 | -- 19 | -------------------------------------------------------------------------------- 20 | 21 | module Data.Comp.Multi.Sum 22 | ( 23 | (:<:), 24 | (:+:), 25 | caseH, 26 | 27 | -- * Projections for Signatures and Terms 28 | proj, 29 | project, 30 | deepProject, 31 | 32 | -- * Injections for Signatures and Terms 33 | inj, 34 | inject, 35 | deepInject, 36 | 37 | split, 38 | 39 | -- * Injections and Projections for Constants 40 | injectConst, 41 | projectConst, 42 | injectCxt, 43 | liftCxt, 44 | substHoles, 45 | -- substHoles' 46 | ) where 47 | 48 | import Data.Comp.Multi.Algebra 49 | import Data.Comp.Multi.HFunctor 50 | import Data.Comp.Multi.HTraversable 51 | import Data.Comp.Multi.Ops 52 | import Data.Comp.Multi.Term 53 | 54 | 55 | -- |Project the outermost layer of a term to a sub signature. If the signature 56 | -- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead. 57 | project :: (g :<: f) => NatM Maybe (Cxt h f a) (g (Cxt h f a)) 58 | project (Hole _) = Nothing 59 | project (Term t) = proj t 60 | 61 | 62 | -- | Tries to coerce a term/context to a term/context over a sub-signature. If 63 | -- the signature @g@ is compound of /n/ atomic signatures, use 64 | -- @deepProject@/n/ instead. 65 | deepProject :: (HTraversable g, g :<: f) => CxtFunM Maybe f g 66 | {-# INLINE deepProject #-} 67 | deepProject = appSigFunM' proj 68 | 69 | 70 | -- |Inject a term where the outermost layer is a sub signature. If the signature 71 | -- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead. 72 | inject :: (g :<: f) => g (Cxt h f a) :-> Cxt h f a 73 | inject = Term . inj 74 | 75 | 76 | -- |Inject a term over a sub signature to a term over larger signature. If the 77 | -- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/ 78 | -- instead. 79 | deepInject :: (HFunctor g, g :<: f) => CxtFun g f 80 | {-# INLINE deepInject #-} 81 | deepInject = appSigFun inj 82 | 83 | 84 | split :: (f :=: f1 :+: f2) => (f1 (Term f) :-> a) -> (f2 (Term f) :-> a) -> Term f :-> a 85 | split f1 f2 (Term t) = spl f1 f2 t 86 | 87 | 88 | -- | This function injects a whole context into another context. 89 | injectCxt :: (HFunctor g, g :<: f) => Cxt h' g (Cxt h f a) :-> Cxt h f a 90 | injectCxt = cata' inject 91 | 92 | -- | This function lifts the given functor to a context. 93 | liftCxt :: (HFunctor f, g :<: f) => g a :-> Context f a 94 | liftCxt g = simpCxt $ inj g 95 | 96 | -- | This function applies the given context with hole type @a@ to a 97 | -- family @f@ of contexts (possibly terms) indexed by @a@. That is, 98 | -- each hole @h@ is replaced by the context @f h@. 99 | 100 | substHoles :: (HFunctor f, HFunctor g, f :<: g) 101 | => (v :-> Cxt h g a) -> Cxt h' f v :-> Cxt h g a 102 | substHoles f c = injectCxt $ hfmap f c 103 | 104 | injectConst :: (HFunctor g, g :<: f) => Const g :-> Cxt h f a 105 | injectConst = inject . hfmap (const undefined) 106 | 107 | projectConst :: (HFunctor g, g :<: f) => NatM Maybe (Cxt h f a) (Const g) 108 | projectConst = fmap (hfmap (const (K ()))) . project 109 | -------------------------------------------------------------------------------- /src/Data/Comp/Multi/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Comp.Multi.Term 10 | -- Copyright : (c) 2011 Patrick Bahr 11 | -- License : BSD3 12 | -- Maintainer : Patrick Bahr 13 | -- Stability : experimental 14 | -- Portability : non-portable (GHC Extensions) 15 | -- 16 | -- This module defines the central notion of mutual recursive (or, higher-order) 17 | -- /terms/ and its generalisation to (higher-order) contexts. All definitions 18 | -- are generalised versions of those in "Data.Comp.Term". 19 | -- 20 | -------------------------------------------------------------------------------- 21 | 22 | module Data.Comp.Multi.Term 23 | (Cxt (..), 24 | Hole, 25 | NoHole, 26 | Context, 27 | Term, 28 | Const, 29 | constTerm, 30 | unTerm, 31 | toCxt, 32 | simpCxt 33 | ) where 34 | 35 | import Data.Comp.Multi.HFoldable 36 | import Data.Comp.Multi.HFunctor 37 | import Data.Comp.Multi.HTraversable 38 | 39 | import Data.Kind 40 | 41 | import Control.Monad 42 | 43 | import Unsafe.Coerce 44 | 45 | type Const (f :: (Type -> Type) -> Type -> Type) = f (K ()) 46 | 47 | -- | This function converts a constant to a term. This assumes that 48 | -- the argument is indeed a constant, i.e. does not have a value for 49 | -- the argument type of the functor f. 50 | 51 | constTerm :: (HFunctor f) => Const f :-> Term f 52 | constTerm = Term . hfmap (const undefined) 53 | 54 | -- | This data type represents contexts over a signature. Contexts are 55 | -- terms containing zero or more holes. The first type parameter is 56 | -- supposed to be one of the phantom types 'Hole' and 'NoHole'. The 57 | -- second parameter is the signature of the context. The third 58 | -- parameter is the type family of the holes. The last parameter is 59 | -- the index/label. 60 | 61 | data Cxt h f a i where 62 | Term :: f (Cxt h f a) i -> Cxt h f a i 63 | Hole :: a i -> Cxt Hole f a i 64 | 65 | -- | Phantom type that signals that a 'Cxt' might contain holes. 66 | data Hole 67 | -- | Phantom type that signals that a 'Cxt' does not contain holes. 68 | data NoHole 69 | 70 | -- | A context might contain holes. 71 | type Context = Cxt Hole 72 | 73 | -- | A (higher-order) term is a context with no holes. 74 | type Term f = Cxt NoHole f (K ()) 75 | 76 | -- | This function unravels the given term at the topmost layer. 77 | unTerm :: Term f t -> f (Term f) t 78 | unTerm (Term t) = t 79 | 80 | instance (HFunctor f) => HFunctor (Cxt h f) where 81 | hfmap f (Hole x) = Hole (f x) 82 | hfmap f (Term t) = Term (hfmap (hfmap f) t) 83 | 84 | instance (HFoldable f) => HFoldable (Cxt h f) where 85 | hfoldr = hfoldr' where 86 | hfoldr' :: forall a b. (a :=> (b -> b)) -> b -> Cxt h f a :=> b 87 | hfoldr' op c a = run a c where 88 | run :: (Cxt h f) a :=> (b -> b) 89 | run (Hole a) e = a `op` e 90 | run (Term t) e = hfoldr run e t 91 | 92 | hfoldl = hfoldl' where 93 | hfoldl' :: forall a b. (b -> a :=> b) -> b -> Cxt h f a :=> b 94 | hfoldl' op = run where 95 | run :: b -> (Cxt h f) a :=> b 96 | run e (Hole a) = e `op` a 97 | run e (Term t) = hfoldl run e t 98 | 99 | hfold (Hole (K a)) = a 100 | hfold (Term t) = hfoldMap hfold t 101 | 102 | hfoldMap = hfoldMap' where 103 | hfoldMap' :: forall m a. Monoid m => (a :=> m) -> Cxt h f a :=> m 104 | hfoldMap' f = run where 105 | run :: Cxt h f a :=> m 106 | run (Hole a) = f a 107 | run (Term t) = hfoldMap run t 108 | 109 | instance (HTraversable f) => HTraversable (Cxt h f) where 110 | hmapM = hmapM' where 111 | hmapM' :: forall m a b. (Monad m) => NatM m a b -> NatM m (Cxt h f a) (Cxt h f b) 112 | hmapM' f = run where 113 | run :: NatM m (Cxt h f a) (Cxt h f b) 114 | run (Hole x) = liftM Hole $ f x 115 | run (Term t) = liftM Term $ hmapM run t 116 | htraverse f (Hole x) = Hole <$> f x 117 | htraverse f (Term t) = Term <$> htraverse (htraverse f) t 118 | 119 | simpCxt :: (HFunctor f) => f a i -> Context f a i 120 | simpCxt = Term . hfmap Hole 121 | 122 | {-| Cast a term over a signature to a context over the same signature. -} 123 | toCxt :: (HFunctor f) => Term f :-> Context f a 124 | {-# INLINE toCxt #-} 125 | toCxt = unsafeCoerce 126 | -- equivalentto @Term . (hfmap toCxt) . unTerm@ 127 | -------------------------------------------------------------------------------- /src/Data/Comp/Ordering.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | -------------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.Comp.Ordering 7 | -- Copyright : (c) 2010-2011 Patrick Bahr 8 | -- License : BSD3 9 | -- Maintainer : Patrick Bahr 10 | -- Stability : experimental 11 | -- Portability : non-portable (GHC Extensions) 12 | -- 13 | -- This module defines ordering of signatures, which lifts to ordering of 14 | -- terms and contexts. 15 | -- 16 | -------------------------------------------------------------------------------- 17 | module Data.Comp.Ordering 18 | ( 19 | OrdF(..) 20 | ) where 21 | 22 | import Data.Comp.Derive 23 | import Data.Comp.Derive.Utils 24 | import Data.Comp.Equality () 25 | import Data.Comp.Ops 26 | import Data.Comp.Term 27 | 28 | {-| 29 | From an 'OrdF' functor an 'Ord' instance of the corresponding 30 | term type can be derived. 31 | -} 32 | instance (OrdF f, Ord a) => Ord (Cxt h f a) where 33 | compare = compareF 34 | 35 | instance OrdF f => OrdF (Cxt h f) where 36 | compareF (Term e1) (Term e2) = compareF e1 e2 37 | compareF (Hole h1) (Hole h2) = compare h1 h2 38 | compareF Term{} Hole{} = LT 39 | compareF Hole{} Term{} = GT 40 | 41 | -- instance (OrdF f, Ord p) => OrdF (f :*: p) where 42 | -- compareF (v1 :*: p1) (v2 :*: p2) = 43 | -- case compareF v1 v2 of 44 | -- EQ -> compare p1 p2 45 | -- res -> res 46 | 47 | {-| 48 | 'OrdF' is propagated through sums. 49 | -} 50 | instance (OrdF f, OrdF g) => OrdF (f :+: g) where 51 | compareF (Inl _) (Inr _) = LT 52 | compareF (Inr _) (Inl _) = GT 53 | compareF (Inl x) (Inl y) = compareF x y 54 | compareF (Inr x) (Inr y) = compareF x y 55 | 56 | $(derive [makeOrdF] $ [''Maybe, ''[]] ++ tupleTypes 2 10) 57 | -------------------------------------------------------------------------------- /src/Data/Comp/Projection.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- 15 | -- | 16 | -- Module : Data.Comp.Projection 17 | -- Copyright : (c) 2014 Patrick Bahr 18 | -- License : BSD3 19 | -- Maintainer : Patrick Bahr 20 | -- Stability : experimental 21 | -- Portability : non-portable (GHC Extensions) 22 | -- 23 | -- This module provides a generic projection function 'pr' for 24 | -- arbitrary nested binary products. 25 | -- 26 | -------------------------------------------------------------------------------- 27 | 28 | 29 | module Data.Comp.Projection (pr, (:<)) where 30 | 31 | import Data.Comp.SubsumeCommon 32 | 33 | import Data.Kind 34 | 35 | type family Elem (f :: Type) 36 | (g :: Type) :: Emb where 37 | Elem f f = Found Here 38 | Elem (f1, f2) g = Sum' (Elem f1 g) (Elem f2 g) 39 | Elem f (g1, g2) = Choose (Elem f g1) (Elem f g2) 40 | Elem f g = NotFound 41 | 42 | class Proj (e :: Emb) (p :: Type) 43 | (q :: Type) where 44 | pr' :: Proxy e -> q -> p 45 | 46 | instance Proj (Found Here) f f where 47 | pr' _ = id 48 | 49 | instance Proj (Found p) f g => Proj (Found (Le p)) f (g, g') where 50 | pr' _ = pr' (P :: Proxy (Found p)) . fst 51 | 52 | 53 | instance Proj (Found p) f g => Proj (Found (Ri p)) f (g', g) where 54 | pr' _ = pr' (P :: Proxy (Found p)) . snd 55 | 56 | 57 | instance (Proj (Found p1) f1 g, Proj (Found p2) f2 g) 58 | => Proj (Found (Sum p1 p2)) (f1, f2) g where 59 | pr' _ x = (pr' (P :: Proxy (Found p1)) x, pr' (P :: Proxy (Found p2)) x) 60 | 61 | 62 | infixl 5 :< 63 | 64 | -- | The constraint @e :< p@ expresses that @e@ is a component of the 65 | -- type @p@. That is, @p@ is formed by binary products using the type 66 | -- @e@. The occurrence of @e@ must be unique. For example we have @Int 67 | -- :< (Bool,(Int,Bool))@ but not @Bool :< (Bool,(Int,Bool))@. 68 | 69 | type f :< g = (Proj (ComprEmb (Elem f g)) f g) 70 | 71 | 72 | -- | This function projects the component of type @e@ out or the 73 | -- compound value of type @p@. 74 | 75 | pr :: forall p q . (p :< q) => q -> p 76 | pr = pr' (P :: Proxy (ComprEmb (Elem p q))) 77 | -------------------------------------------------------------------------------- /src/Data/Comp/Render.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | module Data.Comp.Render where 4 | 5 | import Data.Comp 6 | import Data.Comp.Derive 7 | import Data.Comp.Show () 8 | import Data.Foldable (toList) 9 | import Data.Tree (Tree (..)) 10 | import Data.Tree.View 11 | 12 | -- | The 'stringTree' algebra of a functor. The default instance creates a tree 13 | -- with the same structure as the term. 14 | class (Functor f, Foldable f, ShowConstr f) => Render f where 15 | stringTreeAlg :: Alg f (Tree String) 16 | stringTreeAlg f = Node (showConstr f) $ toList f 17 | 18 | -- | Convert a term to a 'Tree' 19 | stringTree :: Render f => Term f -> Tree String 20 | stringTree = cata stringTreeAlg 21 | 22 | -- | Show a term using ASCII art 23 | showTerm :: Render f => Term f -> String 24 | showTerm = showTree . stringTree 25 | 26 | -- | Print a term using ASCII art 27 | drawTerm :: Render f => Term f -> IO () 28 | drawTerm = putStrLn . showTerm 29 | 30 | -- | Write a term to an HTML file with foldable nodes 31 | writeHtmlTerm :: Render f => FilePath -> Term f -> IO () 32 | writeHtmlTerm file 33 | = writeHtmlTree Nothing file 34 | . fmap (\n -> NodeInfo InitiallyExpanded n "") . stringTree 35 | 36 | $(derive [liftSum] [''Render]) 37 | -------------------------------------------------------------------------------- /src/Data/Comp/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | -------------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Data.Comp.Show 8 | -- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved 9 | -- License : BSD3 10 | -- Maintainer : Patrick Bahr 11 | -- Stability : experimental 12 | -- Portability : non-portable (GHC Extensions) 13 | -- 14 | -- This module defines showing of signatures, which lifts to showing of 15 | -- terms and contexts. 16 | -- 17 | -------------------------------------------------------------------------------- 18 | 19 | module Data.Comp.Show 20 | ( ShowF(..) 21 | ) where 22 | 23 | import Data.Comp.Algebra 24 | import Data.Comp.Annotation 25 | import Data.Comp.Derive (liftSum) 26 | import Data.Comp.Derive.Show 27 | import Data.Comp.Derive.Utils (derive) 28 | import Data.Comp.Term 29 | 30 | instance (Functor f, ShowF f) => ShowF (Cxt h f) where 31 | showF (Hole s) = s 32 | showF (Term t) = showF $ fmap showF t 33 | 34 | instance (Functor f, ShowF f, Show a) => Show (Cxt h f a) where 35 | show = free showF show 36 | 37 | instance (ShowF f, Show p) => ShowF (f :&: p) where 38 | showF (v :&: p) = showF v ++ " :&: " ++ show p 39 | 40 | $(derive [liftSum] [''ShowF]) 41 | $(derive [makeShowF] [''Maybe, ''[], ''(,)]) 42 | 43 | instance (ShowConstr f, Show p) => ShowConstr (f :&: p) where 44 | showConstr (v :&: p) = showConstr v ++ " :&: " ++ show p 45 | 46 | $(derive [liftSum] [''ShowConstr]) 47 | -------------------------------------------------------------------------------- /src/Data/Comp/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | -------------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Data.Comp.Term 10 | -- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved 11 | -- License : BSD3 12 | -- Maintainer : Patrick Bahr 13 | -- Stability : experimental 14 | -- Portability : non-portable (GHC Extensions) 15 | -- 16 | -- This module defines the central notion of /terms/ and its 17 | -- generalisation to contexts. 18 | -- 19 | -------------------------------------------------------------------------------- 20 | 21 | module Data.Comp.Term 22 | (Cxt (..), 23 | Hole, 24 | NoHole, 25 | Context, 26 | Term, 27 | PTerm, 28 | Const, 29 | unTerm, 30 | simpCxt, 31 | toCxt, 32 | constTerm 33 | ) where 34 | 35 | import Control.Applicative hiding (Const) 36 | import Control.Monad hiding (mapM, sequence) 37 | 38 | import Data.Kind 39 | import Data.Foldable 40 | import Data.Traversable 41 | import Unsafe.Coerce 42 | 43 | import Prelude hiding (foldl, foldl1, foldr, foldr1, mapM, sequence) 44 | 45 | 46 | {-| -} 47 | type Const f = f () 48 | 49 | {-| This function converts a constant to a term. This assumes that the 50 | argument is indeed a constant, i.e. does not have a value for the 51 | argument type of the functor @f@. -} 52 | 53 | constTerm :: (Functor f) => Const f -> Term f 54 | constTerm = Term . fmap (const undefined) 55 | 56 | {-| This data type represents contexts over a signature. Contexts are 57 | terms containing zero or more holes. The first type parameter is 58 | supposed to be one of the phantom types 'Hole' and 'NoHole'. The 59 | second parameter is the signature of the context. The third parameter 60 | is the type of the holes. -} 61 | 62 | data Cxt :: Type -> (Type -> Type) -> Type -> Type where 63 | Term :: f (Cxt h f a) -> Cxt h f a 64 | Hole :: a -> Cxt Hole f a 65 | 66 | 67 | {-| Phantom type that signals that a 'Cxt' might contain holes. -} 68 | 69 | data Hole 70 | 71 | {-| Phantom type that signals that a 'Cxt' does not contain holes. 72 | -} 73 | 74 | data NoHole 75 | 76 | type Context = Cxt Hole 77 | 78 | {-| Convert a functorial value into a context. -} 79 | simpCxt :: Functor f => f a -> Context f a 80 | {-# INLINE simpCxt #-} 81 | simpCxt = Term . fmap Hole 82 | 83 | 84 | {-| Cast a term over a signature to a context over the same signature. -} 85 | toCxt :: Functor f => Term f -> Cxt h f a 86 | {-# INLINE toCxt #-} 87 | toCxt = unsafeCoerce 88 | -- equivalent to @Term . (fmap toCxt) . unTerm@ 89 | 90 | {-| A term is a context with no holes. -} 91 | type Term f = Cxt NoHole f () 92 | 93 | -- | Polymorphic definition of a term. This formulation is more 94 | -- natural than 'Term', it leads to impredicative types in some cases, 95 | -- though. 96 | type PTerm f = forall h a . Cxt h f a 97 | 98 | instance Functor f => Functor (Cxt h f) where 99 | fmap f = run 100 | where run (Hole v) = Hole (f v) 101 | run (Term t) = Term (fmap run t) 102 | 103 | instance Functor f => Applicative (Context f) where 104 | pure = Hole 105 | (<*>) = ap 106 | 107 | instance (Functor f) => Monad (Context f) where 108 | m >>= f = run m 109 | where run (Hole v) = f v 110 | run (Term t) = Term (fmap run t) 111 | 112 | instance (Foldable f) => Foldable (Cxt h f) where 113 | foldr op c a = run a c 114 | where run (Hole a) e = a `op` e 115 | run (Term t) e = foldr run e t 116 | 117 | foldl op = run 118 | where run e (Hole a) = e `op` a 119 | run e (Term t) = foldl run e t 120 | 121 | fold (Hole a) = a 122 | fold (Term t) = foldMap fold t 123 | 124 | foldMap f = run 125 | where run (Hole a) = f a 126 | run (Term t) = foldMap run t 127 | 128 | instance (Traversable f) => Traversable (Cxt h f) where 129 | traverse f = run 130 | where run (Hole a) = Hole <$> f a 131 | run (Term t) = Term <$> traverse run t 132 | 133 | sequenceA (Hole a) = Hole <$> a 134 | sequenceA (Term t) = Term <$> traverse sequenceA t 135 | 136 | mapM f = run 137 | where run (Hole a) = liftM Hole $ f a 138 | run (Term t) = liftM Term $ mapM run t 139 | 140 | sequence (Hole a) = liftM Hole a 141 | sequence (Term t) = liftM Term $ mapM sequence t 142 | 143 | 144 | 145 | {-| This function unravels the given term at the topmost layer. -} 146 | 147 | unTerm :: Cxt NoHole f a -> f (Cxt NoHole f a) 148 | {-# INLINE unTerm #-} 149 | unTerm (Term t) = t 150 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Equality_Test.hs: -------------------------------------------------------------------------------- 1 | module Data.Comp.Equality_Test where 2 | 3 | 4 | import Data.Comp 5 | import Data.Comp.Equality () 6 | import Data.Comp.Arbitrary () 7 | import Data.Comp.Show () 8 | 9 | import Test.Framework 10 | import Test.Framework.Providers.QuickCheck2 11 | import Test.Utils 12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- 18 | -- Test Suits 19 | -------------------------------------------------------------------------------- 20 | 21 | main = defaultMain [tests] 22 | 23 | tests = testGroup "Equality" [ 24 | testProperty "prop_eqMod_fmap" prop_eqMod_fmap 25 | ] 26 | 27 | 28 | -------------------------------------------------------------------------------- 29 | -- Properties 30 | -------------------------------------------------------------------------------- 31 | 32 | prop_eqMod_fmap cxt f = case eqMod cxt cxt' of 33 | Nothing -> False 34 | Just list -> all (uncurry (==)) $ map (\(x,y)->(f x,y)) list 35 | where cxt' = fmap f cxt 36 | _with = (cxt :: Context SigP Int, f :: Int -> Int) 37 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Examples/Comp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Data.Comp.Examples.Comp where 3 | 4 | import Examples.Common 5 | import Examples.Eval as Eval 6 | import Examples.EvalM as EvalM 7 | import Examples.Desugar as Desugar 8 | 9 | import Data.Comp 10 | 11 | import Test.Framework 12 | import Test.Framework.Providers.HUnit 13 | import Test.HUnit 14 | 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Test Suits 18 | -------------------------------------------------------------------------------- 19 | 20 | tests = testGroup "Compositional Data Types" [ 21 | testCase "eval" evalTest, 22 | testCase "evalM" evalMTest, 23 | testCase "desugarEval" desugarEvalTest, 24 | testCase "desugarPos" desugarPosTest 25 | ] 26 | 27 | 28 | -------------------------------------------------------------------------------- 29 | -- Properties 30 | -------------------------------------------------------------------------------- 31 | 32 | instance (EqF f, Eq p) => EqF (f :&: p) where 33 | eqF (v1 :&: p1) (v2 :&: p2) = p1 == p2 && v1 `eqF` v2 34 | 35 | evalTest = Eval.evalEx @=? iConst 5 36 | evalMTest = evalMEx @=? Just (iConst 5) 37 | desugarEvalTest = Desugar.evalEx @=? iPair (iConst 2) (iConst 1) 38 | desugarPosTest = desugPEx @=? iAPair (Pos 1 0) 39 | (iASnd (Pos 1 0) 40 | (iAPair (Pos 1 1) 41 | (iAConst (Pos 1 2) 1) 42 | (iAConst (Pos 1 3) 2))) 43 | (iAFst (Pos 1 0) 44 | (iAPair (Pos 1 1) 45 | (iAConst (Pos 1 2) 1) 46 | (iAConst (Pos 1 3) 2))) 47 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Examples/Multi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Data.Comp.Examples.Multi where 3 | 4 | import Examples.Multi.Common 5 | import Examples.Multi.Eval as Eval 6 | import Examples.Multi.EvalI as EvalI 7 | import Examples.Multi.EvalM as EvalM 8 | import Examples.Multi.Desugar as Desugar 9 | 10 | import Data.Comp.Multi 11 | 12 | import Test.Framework 13 | import Test.Framework.Providers.HUnit 14 | import Test.HUnit 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Test Suits 18 | -------------------------------------------------------------------------------- 19 | 20 | tests = testGroup "Generalised Compositional Data Types" [ 21 | testCase "eval" evalTest, 22 | testCase "evalI" evalITest, 23 | testCase "evalM" evalMTest, 24 | testCase "desugarEval" desugarEvalTest, 25 | testCase "desugarPos" desugarPosTest 26 | ] 27 | 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Properties 31 | -------------------------------------------------------------------------------- 32 | 33 | instance (EqHF f, Eq p) => EqHF (f :&: p) where 34 | eqHF (v1 :&: p1) (v2 :&: p2) = p1 == p2 && v1 `eqHF` v2 35 | 36 | evalTest = Eval.evalEx @=? iConst 2 37 | evalITest = evalIEx @=? 2 38 | evalMTest = evalMEx @=? Just (iConst 5) 39 | desugarEvalTest = Desugar.evalEx @=? iPair (iConst 2) (iConst 1) 40 | desugarPosTest = desugPEx @=? iAPair (Pos 1 0) 41 | (iASnd (Pos 1 0) 42 | (iAPair (Pos 1 1) 43 | (iAConst (Pos 1 2) 1) 44 | (iAConst (Pos 1 3) 2))) 45 | (iAFst (Pos 1 0) 46 | (iAPair (Pos 1 1) 47 | (iAConst (Pos 1 2) 1) 48 | (iAConst (Pos 1 3) 2))) 49 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Examples_Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Data.Comp.Examples_Test where 3 | 4 | import qualified Data.Comp.Examples.Comp as C 5 | import qualified Data.Comp.Examples.Multi as M 6 | 7 | import Test.Framework 8 | 9 | tests = testGroup "Examples" [ 10 | C.tests, 11 | M.tests 12 | ] 13 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Multi/Variables_Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, 2 | MultiParamTypeClasses, TypeOperators, FlexibleContexts , RankNTypes, 3 | GADTs, ScopedTypeVariables, EmptyDataDecls, ConstraintKinds #-} 4 | 5 | module Data.Comp.Multi.Variables_Test where 6 | 7 | 8 | import Data.Comp.Multi.Variables 9 | import Data.Comp.Multi.Derive 10 | import Data.Comp.Multi.Sum 11 | import Data.Comp.Multi.Term 12 | import Data.Comp.Multi.HFunctor 13 | import Data.Comp.Multi.Show () 14 | 15 | import qualified Data.Map as Map 16 | import qualified Data.Set as Set 17 | 18 | import Test.Framework 19 | import Test.Framework.Providers.HUnit 20 | import Test.HUnit 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- 25 | -- Definitions 26 | -------------------------------------------------------------------------------- 27 | 28 | data Var = X | Y | Z deriving (Eq,Ord,Show) 29 | 30 | 31 | data Ex 32 | 33 | type Value f = forall i . Term f i 34 | type Expression f = Term f Ex 35 | 36 | data Val e i where 37 | Abs :: Var -> e Ex -> Val e i 38 | Var :: Var -> Val e i 39 | Int :: Int -> Val e i 40 | 41 | 42 | data Op e i where 43 | App :: e Ex -> e Ex -> Op e Ex 44 | Plus :: e Ex -> e Ex -> Op e Ex 45 | 46 | 47 | data Let e i where 48 | Let :: Var -> e Ex -> e Ex -> Let e Ex 49 | 50 | data LetRec e i where 51 | LetRec :: Var -> e Ex -> e Ex -> LetRec e Ex 52 | 53 | type Sig = Op :+: Val 54 | 55 | type SigLet = Let :+: Sig 56 | 57 | type SigRec = LetRec :+: Sig 58 | 59 | $(derive [makeHFunctor, makeHTraversable, makeHFoldable, 60 | makeEqHF, makeShowHF, smartConstructors] 61 | [''Op, ''Val, ''Let, ''LetRec]) 62 | 63 | instance HasVars Val Var where 64 | isVar (Var v) = Just v 65 | isVar _ = Nothing 66 | 67 | bindsVars (Abs v a) = a |-> Set.singleton v 68 | bindsVars _ = empty 69 | 70 | instance HasVars Op a where 71 | 72 | instance HasVars Let Var where 73 | bindsVars (Let v _ a) = a |-> Set.singleton v 74 | 75 | instance HasVars LetRec Var where 76 | bindsVars (LetRec v a b) = a |-> vs & b |-> vs 77 | where vs = Set.singleton v 78 | 79 | -- let x = x + 1 in (\y. y + x) z 80 | letExp, letExp' :: Expression SigLet 81 | letExp = iLet X (iVar X `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iVar Z) 82 | letExp' = iLet X (iInt 1 `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iInt 3) 83 | 84 | -- letrec x = x + 1 in (\y. y + x) z 85 | recExp, recExp' :: Expression SigRec 86 | recExp = iLetRec X (iVar X `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iVar Z) 87 | recExp' = iLetRec X (iVar X `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iInt 3) 88 | 89 | subst :: (Val :<: f) => Subst f Var 90 | subst = Map.fromList [(X, A $ iInt 1), (Y, A $ iInt 2), (Z, A $ iInt 3)] 91 | 92 | -------------------------------------------------------------------------------- 93 | -- Properties 94 | -------------------------------------------------------------------------------- 95 | 96 | case_letFree = variables letExp @=? Set.fromList [Z,X] 97 | 98 | case_recFree = variables recExp @=? Set.fromList [Z] 99 | 100 | case_letSubst = appSubst s letExp @=? letExp' 101 | where s = subst :: Subst SigLet Var 102 | 103 | case_recSubst = appSubst s recExp @=? recExp' 104 | where s = subst :: Subst SigRec Var 105 | 106 | -------------------------------------------------------------------------------- 107 | -- Test Suits 108 | -------------------------------------------------------------------------------- 109 | 110 | main = defaultMain [tests] 111 | 112 | tests = testGroup "Variables" [ 113 | testCase "case_letFree" case_letFree 114 | ,testCase "case_recFree" case_recFree 115 | ,testCase "case_letSubst" case_letSubst 116 | ,testCase "case_recSubst" case_recSubst 117 | ] 118 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Multi_Test.hs: -------------------------------------------------------------------------------- 1 | module Data.Comp.Multi_Test where 2 | 3 | import Test.Framework 4 | import qualified Data.Comp.Multi.Variables_Test 5 | 6 | -------------------------------------------------------------------------------- 7 | -- Test Suits 8 | -------------------------------------------------------------------------------- 9 | 10 | main = defaultMain [tests] 11 | 12 | tests = testGroup "Multi" [ 13 | Data.Comp.Multi.Variables_Test.tests 14 | ] 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Properties 18 | -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Subsume_Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, DataKinds, TypeFamilies #-} 2 | 3 | -- | This module exports a dummy test to force type checking of this 4 | -- module. In this module we test the subtyping system. 5 | 6 | module Data.Comp.Subsume_Test where 7 | 8 | import Data.Comp 9 | import Data.Comp.Ops 10 | import Data.Comp.SubsumeCommon 11 | 12 | 13 | import Test.Framework 14 | import Test.Framework.Providers.QuickCheck2 15 | 16 | 17 | data S1 a = S1 a 18 | data S2 a = S2 a 19 | data S3 a = S3 a 20 | data S4 a = S4 a 21 | 22 | type TA = S1 :+: S2 23 | type TB = S3 :+: S4 24 | type T1 = TA :+: TB 25 | type T2 = TB :+: TA 26 | type T3 = S2 :+: TB 27 | 28 | test1 :: ComprEmb (Elem T1 T1) ~ (Found Here) => Int 29 | test1 = 1 30 | 31 | test2 :: ComprEmb (Elem T1 T2) ~ (Found (Sum (Ri Here) (Le Here))) => Int 32 | test2 = 1 33 | 34 | test3 :: ComprEmb (Elem (T1 :+: S1) T2) ~ Ambiguous => Int 35 | test3 = 1 36 | 37 | test4 :: ComprEmb (Elem T1 (T2 :+: S1)) ~ Ambiguous => Int 38 | test4 = 1 39 | 40 | test5 :: ComprEmb (Elem T1 T3) ~ NotFound => Int 41 | test5 = 1 42 | 43 | test6 :: ComprEmb (Elem TB T1) ~ (Found (Ri Here)) => Int 44 | test6 = 1 45 | 46 | test7 :: ComprEmb (Elem T3 T1) ~ (Found (Sum (Le (Ri Here))(Ri Here))) => Int 47 | test7 = 1 48 | 49 | main = defaultMain [tests] 50 | 51 | tests = testGroup "Subsume" [ 52 | testProperty "prop_typecheck" prop_typecheck 53 | ] 54 | 55 | -- dummy test 56 | prop_typecheck = True 57 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp/Variables_Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, 2 | TypeOperators, FlexibleContexts, ConstraintKinds #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | 5 | module Data.Comp.Variables_Test where 6 | 7 | 8 | import Data.Comp.Variables 9 | import Data.Comp.Derive 10 | import Data.Comp.Sum 11 | import Data.Comp.Term 12 | import Data.Comp.Show () 13 | 14 | import qualified Data.Map as Map 15 | import qualified Data.Set as Set 16 | 17 | import Test.Framework 18 | import Test.Framework.Providers.HUnit 19 | import Test.HUnit 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Definitions 25 | -------------------------------------------------------------------------------- 26 | 27 | data Var = X | Y | Z deriving (Eq,Ord,Show) 28 | 29 | 30 | data Val e = Abs Var e 31 | | Var Var 32 | | Int Int 33 | deriving Functor 34 | 35 | data Op e = App e e 36 | | Plus e e 37 | deriving Functor 38 | 39 | data Let e = Let Var e e 40 | deriving Functor 41 | 42 | data LetRec e = LetRec Var e e 43 | deriving Functor 44 | 45 | type Sig = Op :+: Val 46 | 47 | type SigLet = Let :+: Sig 48 | 49 | type SigRec = LetRec :+: Sig 50 | 51 | $(derive [makeTraversable, makeFoldable, 52 | makeEqF, makeShowF, smartConstructors] 53 | [''Op, ''Val, ''Let, ''LetRec]) 54 | 55 | instance HasVars Val Var where 56 | isVar (Var v) = Just v 57 | isVar _ = Nothing 58 | 59 | bindsVars (Abs v a) = a |-> Set.singleton v 60 | bindsVars _ = empty 61 | 62 | instance HasVars Op a where 63 | 64 | instance HasVars Let Var where 65 | bindsVars (Let v _ a) = a |-> Set.singleton v 66 | 67 | instance HasVars LetRec Var where 68 | bindsVars (LetRec v a b) = a |-> vs & b |-> vs 69 | where vs = Set.singleton v 70 | 71 | -- let x = x + 1 in (\y. y + x) z 72 | letExp, letExp' :: Term SigLet 73 | letExp = iLet X (iVar X `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iVar Z) 74 | letExp' = iLet X (iInt 1 `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iInt 3) 75 | 76 | -- letrec x = x + 1 in (\y. y + x) z 77 | recExp, recExp' :: Term SigRec 78 | recExp = iLetRec X (iVar X `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iVar Z) 79 | recExp' = iLetRec X (iVar X `iPlus` iInt 1) (iAbs Y (iVar Y `iPlus` iVar X) `iApp` iInt 3) 80 | 81 | subst :: (Val :<: f) => Subst f Var 82 | subst = Map.fromList [(X, iInt 1), (Y, iInt 2), (Z, iInt 3)] 83 | 84 | -------------------------------------------------------------------------------- 85 | -- Properties 86 | -------------------------------------------------------------------------------- 87 | 88 | case_letFree = Set.fromList [Z,X] @=? variables letExp 89 | 90 | case_recFree = Set.fromList [Z] @=? variables recExp 91 | 92 | case_letSubst = letExp' @=? appSubst s letExp 93 | where s = subst :: Subst SigLet Var 94 | 95 | case_recSubst = recExp' @=? appSubst s recExp 96 | where s = subst :: Subst SigRec Var 97 | 98 | -------------------------------------------------------------------------------- 99 | -- Test Suits 100 | -------------------------------------------------------------------------------- 101 | 102 | main = defaultMain [tests] 103 | 104 | tests = testGroup "Variables" [ 105 | testCase "case_letFree" case_letFree 106 | ,testCase "case_recFree" case_recFree 107 | ,testCase "case_letSubst" case_letSubst 108 | ,testCase "case_recSubst" case_recSubst 109 | ] 110 | -------------------------------------------------------------------------------- /testsuite/tests/Data/Comp_Test.hs: -------------------------------------------------------------------------------- 1 | module Data.Comp_Test where 2 | 3 | import Test.Framework 4 | 5 | import qualified Data.Comp.Equality_Test 6 | import qualified Data.Comp.Examples_Test 7 | import qualified Data.Comp.Variables_Test 8 | import qualified Data.Comp.Multi_Test 9 | import qualified Data.Comp.Subsume_Test 10 | 11 | -------------------------------------------------------------------------------- 12 | -- Test Suits 13 | -------------------------------------------------------------------------------- 14 | 15 | main = defaultMain [tests] 16 | 17 | tests = testGroup "Comp" [ 18 | Data.Comp.Equality_Test.tests, 19 | Data.Comp.Examples_Test.tests, 20 | Data.Comp.Variables_Test.tests, 21 | Data.Comp.Multi_Test.tests, 22 | Data.Comp.Subsume_Test.tests 23 | ] 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Properties 27 | -------------------------------------------------------------------------------- 28 | 29 | -------------------------------------------------------------------------------- /testsuite/tests/Data_Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Framework 4 | import qualified Data.Comp_Test 5 | 6 | -------------------------------------------------------------------------------- 7 | -- Test Suits 8 | -------------------------------------------------------------------------------- 9 | 10 | main = defaultMain [tests] 11 | 12 | tests = testGroup "Data" [ 13 | Data.Comp_Test.tests 14 | ] 15 | 16 | -------------------------------------------------------------------------------- 17 | -- Properties 18 | -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- /testsuite/tests/Test/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleContexts, FlexibleInstances, ConstraintKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | 4 | module Test.Utils where 5 | 6 | import Data.Comp 7 | import Data.Comp.Derive 8 | 9 | 10 | data Tree l e = Leaf l 11 | | UnNode l e 12 | | BinNode e l e 13 | | TerNode l e e e 14 | deriving Functor 15 | 16 | data Pair a e = Pair a e 17 | deriving Functor 18 | 19 | $(derive 20 | [makeFoldable, makeShowF, makeEqF, makeArbitraryF] 21 | [''Tree, ''Pair]) 22 | 23 | $(derive 24 | [smartConstructors] 25 | [''Tree, ''Pair, ''Maybe]) 26 | 27 | 28 | type Sig1 = Maybe :+: Tree Int 29 | type Sig2 = [] :+: Pair Int 30 | type Sig = Maybe :+: Tree Int :+: [] :+: Pair Int 31 | 32 | 33 | type SigP = Maybe :&: Int :+: Tree Int :&: Int :+: [] :&: Int :+: Pair Int :&: Int 34 | 35 | instance EqF f => EqF (f :&: Int) where 36 | eqF (x :&: i) (y :&: j) = x `eqF` y && i == j 37 | 38 | instance Show (a -> b) where 39 | show _ = "" 40 | -------------------------------------------------------------------------------- /upload-doc: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Usage: upload-doc compdata 4 | 5 | cabal haddock --hyperlink-source --html-location='http://hackage.haskell.org/package/$pkg/docs' --contents-location='http://hackage.haskell.org/package/$pkg' 6 | cd "dist/doc/html" 7 | DDIR="${1}-${2}-docs" 8 | cp -r "${1}" "${DDIR}" && tar -c -v -z -f "${DDIR}.tar.gz" "${DDIR}" 9 | CS=$? 10 | if [ "${CS}" -eq "0" ]; then 11 | echo "Uploading to Hackage…" 12 | curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' --data-binary "@${DDIR}.tar.gz" "http://${3}:${4}@hackage.haskell.org/package/${1}-${2}/docs" 13 | exit $? 14 | else 15 | echo "Error when packaging the documentation" 16 | exit $CS 17 | fi 18 | --------------------------------------------------------------------------------