packages feed

compdata 0.6.1.4 → 0.13.1

raw patch · 155 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,10 @@+0.13.1+---++- Compatibility with GHC 9.8++0.13+---++- Compatibility with GHC 9.2, 9.4, 9.6+- GHC version 9.0 and older no longer supported
benchmark/Benchmark.hs view
@@ -11,8 +11,9 @@ import Control.DeepSeq import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen-import System.Random+import Test.QuickCheck.Random + aExpr :: SugarExpr aExpr = iIf ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))             `iOr` ((iVInt 1 `iGt` (iVInt 2 `iMinus` iVInt 1))))@@ -41,10 +42,10 @@     where depth = 15  standardBenchmarks :: (PExpr, SugarExpr, String) -> Benchmark-standardBenchmarks  (sExpr,aExpr,n) = rnf aExpr `seq` rnf sExpr `seq` getBench (sExpr, aExpr,n)-    where getBench (sExpr, aExpr,n) = bgroup n paperBenchmarks+standardBenchmarks  (sExpr,aExpr,n) = rnf aExpr `seq` rnf sExpr `seq` getBench n+    where getBench n = bgroup n paperBenchmarks           -- these are the benchmarks for evaluation-          evalBenchmarks = [+          _evalBenchmarks = [                  bench "evalDesug" (nf A.desugEval2 aExpr),                  bench "evalDesug (fusion)" (nf A.desugEval2' aExpr),                  bench "evalDesug (comparison)" (nf S.desugEval2 sExpr),@@ -96,7 +97,7 @@                  bench "freeVarsU" (nf S.freeVarsGen sExpr),                  bench "freeVars (comparison)" (nf S.freeVars sExpr)]           -- these are all the benchmarks-          allBenchmarks = [+          _allBenchmarks = [                  bench "Comp.desug" (nf A.desugExpr aExpr),                  bench "Comp.desug'" (nf A.desugExpr' aExpr),                  bench "Comp.desugAlg" (nf A.desugExpr2 aExpr),@@ -138,7 +139,7 @@  randStdBenchmarks :: Int -> IO Benchmark randStdBenchmarks s = do-  rand <- getStdGen+  rand <- newQCGen   let ty = unGen arbitrary rand s   putStr "size of the type term: "   print $ size ty
benchmark/DataTypes.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE TypeSynonymInstances, CPP #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}  module DataTypes where +-- Control.Monad.Fail import is redundant since GHC 8.8.1+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif++ type Err = Either String -#if __GLASGOW_HASKELL__ < 700-instance Monad Err where-    return = Right-    e >>= f = case e of -                Left m -> Left m-                Right x -> f x+instance MonadFail Err where     fail  = Left-#endif
benchmark/DataTypes/Comp.hs view
@@ -7,7 +7,9 @@   TypeOperators,   ScopedTypeVariables,   TypeSynonymInstances,-  DeriveFunctor#-}+  DeriveFunctor,+  ConstraintKinds,+  DeriveGeneric, DeriveAnyClass #-}  module DataTypes.Comp      ( module DataTypes.Comp,@@ -19,15 +21,16 @@ import Data.Comp import Data.Comp.Ops import Data.Comp.Arbitrary ()-import Data.Comp.Show+import Data.Comp.Show () import Data.Traversable-import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen import Test.QuickCheck.Property  import Control.Monad hiding (sequence_,mapM) import Prelude hiding (sequence_,mapM) +import GHC.Generics (Generic)+ -- base values  type ValueSig = Value@@ -39,6 +42,8 @@ type BaseTypeSig = ValueT type BaseType = Term BaseTypeSig ++ data ValueT e = TInt               | TBool               | TPair e e@@ -50,7 +55,7 @@                deriving (Eq, Functor)  data Proj = ProjLeft | ProjRight-            deriving (Eq)+            deriving (Eq, Generic, NFData)  data Op e = Plus e e           | Mult e e@@ -69,7 +74,9 @@              | Impl e e                deriving (Eq, Functor) -$(derive [makeNFData, makeArbitrary] [''Proj])++instance Arbitrary Proj where+  arbitrary = elements [ProjLeft,ProjRight]  $(derive   [makeFoldable, makeTraversable,
benchmark/DataTypes/Standard.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, DeriveDataTypeable,+DeriveGeneric, DeriveAnyClass #-} module DataTypes.Standard      ( module DataTypes.Standard,       module DataTypes      ) where +import GHC.Generics (Generic)+ import DataTypes-import Data.Derive.NFData-import Data.DeriveTH import Data.Data import Control.DeepSeq @@ -15,15 +16,15 @@ data VType = VTInt            | VTBool            | VTPair VType VType-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data SExpr = SInt Int            | SBool Bool            | SPair SExpr SExpr-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data SProj = SProjLeft | SProjRight-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data OExpr = OInt Int            | OBool Bool@@ -36,7 +37,7 @@            | OAnd OExpr OExpr            | ONot OExpr            | OProj SProj OExpr-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data PExpr = PInt Int            | PBool Bool@@ -54,13 +55,13 @@            | PGt PExpr PExpr            | POr PExpr PExpr            | PImpl PExpr PExpr-             deriving (Eq,Typeable,Data)+             deriving (Eq,Typeable,Data, Generic, NFData)  data VHType = VHTInt             | VHTBool             | VHTPair VType VType             | VHTFun VType VType-              deriving (Eq,Typeable,Data)+              deriving (Eq,Typeable,Data, Generic, NFData)  showBinOp :: String -> String -> String -> String showBinOp op x y = "("++ x ++ op ++ y ++ ")"@@ -88,5 +89,3 @@     show VTInt = "Int"     show VTBool = "Bool"     show (VTPair x y) = "(" ++ show x ++ "," ++ show y ++ ")"--$(derives [makeNFData] [''SProj,''SExpr,''OExpr,''PExpr,''VType])
benchmark/Functions/Comp/Desugar.hs view
@@ -6,7 +6,8 @@   UndecidableInstances,   TypeOperators,   ScopedTypeVariables,-  TypeSynonymInstances #-}+  TypeSynonymInstances,+  ConstraintKinds #-}  module Functions.Comp.Desugar where @@ -19,6 +20,8 @@ class (Functor e, Traversable f) => Desug f e where     desugAlg :: Hom f e +$(derive [liftSum] [''Desug])+ desugExpr :: SugarExpr -> Expr desugExpr = desug @@ -33,8 +36,6 @@ {-# INLINE desug' #-} desug' = appHom' desugAlg -$(derive [liftSum] [''Desug])- instance (Value :<: v, Functor v) => Desug Value v where     desugAlg = liftCxt @@ -60,7 +61,8 @@ desug2 :: (Functor f, Desug2 f g) => Term f -> Term g desug2 = cata desugAlg2 -$(derive [liftSum] [''Desug2])+instance (Desug2 f1 g, Desug2 f2 g) => Desug2 (f1 :+: f2) g where+    desugAlg2 = caseF desugAlg2 desugAlg2  instance (Value :<: v) => Desug2 Value v where     desugAlg2 = inject
benchmark/Functions/Comp/Eval.hs view
@@ -6,33 +6,39 @@   UndecidableInstances,   TypeOperators,   ScopedTypeVariables,-  TypeSynonymInstances #-}+  TypeSynonymInstances,+  ConstraintKinds,+  CPP #-}  module Functions.Comp.Eval where  import DataTypes.Comp import Functions.Comp.Desugar import Data.Comp-import Data.Comp.Ops-import Data.Comp.Thunk+import Data.Comp.Thunk hiding (eval, eval2) import Data.Comp.Derive++-- Control.Monad.Fail import is redundant since GHC 8.8.1+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+ import Control.Monad-import Data.Traversable  -- evaluation with thunks  class (Monad m, Traversable v) => EvalT e v m where     evalTAlg :: AlgT m e v +$(derive [liftSum] [''EvalT])+ evalT :: (EvalT e v m, Functor e) => Term e -> m (Term v) evalT = nf . cata evalTAlg -$(derive [liftSum] [''EvalT])--instance (Monad m, Traversable v, Value :<: v) => EvalT Value v m where+instance (Monad m, Traversable v, Value :<: m :+: v) => EvalT Value v m where     evalTAlg = inject -instance (Value :<: v, Traversable v, EqF v, Monad m) => EvalT Op v m where+instance (Value :<: (m :+: v), Value :<: v, Traversable v, EqF v, MonadFail m) => EvalT Op v m where     evalTAlg (Plus x y) = thunk $ do                            VInt i <- whnfPr x                            VInt j <- whnfPr y@@ -65,7 +71,7 @@                               ProjLeft -> x                               ProjRight -> y -instance (Value :<: v, Traversable v, Monad m) => EvalT Sugar v m where+instance (Value :<: (m :+: v), Value :<: v, Traversable v, MonadFail m) => EvalT Sugar v m where     evalTAlg (Neg x) = thunk $ do                          VInt i <- whnfPr x                          return $ iVInt (-i)@@ -94,30 +100,30 @@ class Monad m => Eval e v m where     evalAlg :: e (Term v) -> m (Term v) +$(derive [liftSum] [''Eval])+ eval :: (Traversable e, Eval e v m) => Term e -> m (Term v) eval = cataM evalAlg -$(derive [liftSum] [''Eval])- instance (Value :<: v, Monad m) => Eval Value v m where     evalAlg = return . inject -coerceInt :: (Value :<: v, Monad m) => Term v -> m Int+coerceInt :: (Value :<: v, MonadFail m) => Term v -> m Int coerceInt t = case project t of                 Just (VInt i) -> return i                 _ -> fail "" -coerceBool :: (Value :<: v, Monad m) => Term v -> m Bool+coerceBool :: (Value :<: v, MonadFail m) => Term v -> m Bool coerceBool t = case project t of                 Just (VBool b) -> return b                 _ -> fail "" -coercePair :: (Value :<: v, Monad m) => Term v -> m (Term v, Term v)+coercePair :: (Value :<: v, MonadFail m) => Term v -> m (Term v, Term v) coercePair t = case project t of                 Just (VPair x y) -> return (x,y)                 _ -> fail "" -instance (Value :<: v, EqF v, Monad m) => Eval Op v m where+instance (Value :<: v, EqF v, MonadFail m) => Eval Op v m where     evalAlg (Plus x y) = liftM2 (\ i j -> iVInt (i + j)) (coerceInt x) (coerceInt y)     evalAlg (Mult x y) = liftM2 (\ i j -> iVInt (i * j)) (coerceInt x) (coerceInt y)     evalAlg (If b x y) = liftM select (coerceBool b)@@ -131,7 +137,7 @@                                ProjLeft -> x                                ProjRight -> y -instance (Value :<: v, Monad m) => Eval Sugar v m where+instance (Value :<: v, MonadFail m) => Eval Sugar v m where     evalAlg (Neg x) = liftM (iVInt . negate) (coerceInt x)     evalAlg (Minus x y) = liftM2 (\ i j -> iVInt (i - j)) (coerceInt x) (coerceInt y)     evalAlg (Gt x y) = liftM2 (\ i j -> iVBool (i > j)) (coerceInt x) (coerceInt y)@@ -141,18 +147,18 @@  -- direct evaluation -class Monad m => EvalDir e m where+class MonadFail m => EvalDir e m where     evalDir :: (Traversable f, EvalDir f m) => e (Term f) -> m ValueExpr +$(derive [liftSum] [''EvalDir])+ evalDirect :: (Traversable e, EvalDir e m) => Term e -> m ValueExpr-evalDirect = evalDir . unTerm+evalDirect (Term x) = evalDir x  evalDirectE :: SugarExpr -> Err ValueExpr evalDirectE = evalDirect -$(derive [liftSum] [''EvalDir])--instance (Monad m) => EvalDir Value m where+instance (MonadFail m) => EvalDir Value m where     evalDir (VInt i) = return $ iVInt i     evalDir (VBool i) = return $ iVBool i     evalDir (VPair x y) = liftM2 iVPair (evalDirect x) (evalDirect y)@@ -179,7 +185,7 @@     Just (VPair x y) -> return (x,y)     _ -> fail "" -instance (Monad m) => EvalDir Op m where+instance (MonadFail m) => EvalDir Op m where     evalDir (Plus x y) = liftM2 (\ i j -> iVInt (i + j)) (evalInt x) (evalInt y)     evalDir (Mult x y) = liftM2 (\ i j -> iVInt (i * j)) (evalInt x) (evalInt y)     evalDir (If b x y) = do @@ -194,7 +200,7 @@                                ProjLeft -> x                                ProjRight -> y -instance (Monad m) => EvalDir Sugar m where+instance (MonadFail m) => EvalDir Sugar m where     evalDir (Neg x) = liftM (iVInt . negate) (evalInt x)     evalDir (Minus x y) = liftM2 (\ i j -> iVInt (i - j)) (evalInt x) (evalInt y)     evalDir (Gt x y) = liftM2 (\ i j -> iVBool (i > j)) (evalInt x) (evalInt y)@@ -207,11 +213,11 @@ class Functor e => Eval2 e v where     eval2Alg :: e (Term v) -> Term v +$(derive [liftSum] [''Eval2])+ eval2 :: (Functor e, Eval2 e v) => Term e -> Term v eval2 = cata eval2Alg -$(derive [liftSum] [''Eval2])- instance (Value :<: v) => Eval2 Value v where     eval2Alg = inject @@ -258,13 +264,13 @@ class EvalDir2 e where     evalDir2 :: (EvalDir2 f) => e (Term f) -> ValueExpr +$(derive [liftSum] [''EvalDir2])+ evalDirect2 :: (EvalDir2 e) => Term e -> ValueExpr-evalDirect2 = evalDir2 . unTerm+evalDirect2 (Term x) = evalDir2 x  evalDirectE2 :: SugarExpr -> ValueExpr evalDirectE2 = evalDirect2--$(derive [liftSum] [''EvalDir2])  instance EvalDir2 Value where     evalDir2 (VInt i) = iVInt i
benchmark/Functions/Comp/FreeVars.hs view
@@ -6,7 +6,8 @@   UndecidableInstances,   TypeOperators,   ScopedTypeVariables,-  TypeSynonymInstances #-}+  TypeSynonymInstances,+  ConstraintKinds #-}  module Functions.Comp.FreeVars where
+ benchmark/Functions/Comp/HOAS.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE+  TemplateHaskell,+  MultiParamTypeClasses,+  FlexibleInstances,+  FlexibleContexts,+  UndecidableInstances,+  TypeOperators,+  ScopedTypeVariables,+  TypeSynonymInstances #-}++module Functions.Comp.Desugar where++import DataTypes.Comp+import Data.Comp.ExpFunctor+import Data.Comp+import Data.Foldable+import Prelude hiding (foldr)++ex1 :: HOASExpr+ex1 = iLam (\x -> case project x of+                    Just (VInt _) -> x +                    _ -> x `iPlus` x)+ex2 :: HOASExpr+ex2 = iLam (\x -> case x of+                    Term t -> case proj t of+                                Just (VInt _) -> x +                                _ -> x `iPlus` x)+                                ++class Vars f where+    varsAlg :: Alg f Int++instance (Vars f, Vars g) => Vars (g :+: f) where+    varsAlg (Inl v) = varsAlg v+    varsAlg (Inr v) = varsAlg v++instance Vars Lam where+    varsAlg (Lam f) = f 1++instance Vars App where+    varsAlg = foldr (+) 0++instance Vars Value where+    varsAlg = foldr (+) 0++instance Vars Op where+    varsAlg = foldr (+) 0+++instance Vars Sugar where+    varsAlg = foldr (+) 0++vars :: (ExpFunctor f, Vars f) => Term f -> Int+vars = cataE varsAlg
benchmark/Functions/Comp/Inference.hs view
@@ -6,7 +6,9 @@   UndecidableInstances,   TypeOperators,   ScopedTypeVariables,-  TypeSynonymInstances #-}+  TypeSynonymInstances,+  ConstraintKinds,+  CPP #-}  module Functions.Comp.Inference where @@ -15,6 +17,11 @@ import Data.Comp import Data.Comp.Derive +-- Control.Monad.Fail import is redundant since GHC 8.8.1+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+ -- type inference  class Monad m => InferType f t m where@@ -28,19 +35,19 @@  $(derive [liftSum] [''InferType]) -instance (ValueT :<: t, Monad m) => InferType Value t m where+instance (ValueT :<: t, MonadFail m) => InferType Value t m where     inferTypeAlg (VInt _) = return $ inject TInt     inferTypeAlg (VBool _) = return $ inject TBool     inferTypeAlg (VPair x y) = return $ inject $ TPair x y -checkOp :: (g :<: f, Eq (g (Term f)), Monad m) =>+checkOp :: (g :<: f, Eq (g (Term f)), MonadFail m) =>            [g (Term f)] -> g (Term f) -> [Term f] -> m (Term f) checkOp exs et tys = if and (zipWith (\ f t -> maybe False (==f) (project t)) exs tys)                       then return (inject et)                      else fail""  -instance (ValueT :<: t, EqF t, Monad m) => InferType Op t m where+instance (ValueT :<: t, EqF t, MonadFail m) => InferType Op t m where     inferTypeAlg (Plus x y) = checkOp [TInt,TInt] TInt [x ,y]     inferTypeAlg (Mult x y) = checkOp [TInt,TInt] TInt [x ,y]     inferTypeAlg (Lt x y) = checkOp [TInt,TInt] TBool [x ,y]@@ -57,7 +64,7 @@                                       ProjRight -> return x2                                 _ -> fail "" -instance (ValueT :<: t, EqF t, Monad m) => InferType Sugar t m where+instance (ValueT :<: t, EqF t, MonadFail m) => InferType Sugar t m where     inferTypeAlg (Minus x y) = checkOp [TInt,TInt] TInt [x ,y]     inferTypeAlg (Neg x) = checkOp [TInt] TInt [x]     inferTypeAlg (Gt x y) = checkOp [TInt,TInt] TBool [x ,y]
benchmark/Functions/Standard/Eval.hs view
@@ -1,22 +1,29 @@+{-# LANGUAGE CPP                 #-}+ module Functions.Standard.Eval where  import DataTypes.Standard import Functions.Standard.Desugar import Control.Monad -coerceInt :: (Monad m) => SExpr -> m Int+-- Control.Monad.Fail import is redundant since GHC 8.8.1+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif++coerceInt :: (MonadFail m) => SExpr -> m Int coerceInt (SInt i) = return i coerceInt _ = fail "" -coerceBool :: (Monad m) => SExpr -> m Bool+coerceBool :: (MonadFail m) => SExpr -> m Bool coerceBool (SBool b) = return b coerceBool _ = fail "" -coercePair :: (Monad m) => SExpr -> m (SExpr,SExpr)+coercePair :: (MonadFail m) => SExpr -> m (SExpr,SExpr) coercePair (SPair x y) = return (x,y) coercePair _ = fail "" -eval :: (Monad m) => OExpr -> m SExpr+eval :: (MonadFail m) => OExpr -> m SExpr eval (OInt i) = return $ SInt i eval (OBool b) = return $ SBool b eval (OPair x y) = liftM2 SPair (eval x) (eval y)
benchmark/Functions/Standard/FreeVars.hs view
@@ -1,7 +1,7 @@ module Functions.Standard.FreeVars where  import DataTypes.Standard-import Data.Generics.PlateDirect+import Data.Generics.Uniplate.Direct  instance Uniplate PExpr where     uniplate (PInt x) = plate PInt |- x
benchmark/Functions/Standard/Inference.hs view
@@ -1,17 +1,20 @@ module Functions.Standard.Inference where ++import Control.Monad.Fail import DataTypes.Standard-import Control.Monad+import Prelude hiding (fail)+import Control.Monad hiding (fail) import Functions.Standard.Desugar -checkOp :: (Monad m) => [VType] -> VType -> [OExpr] -> m VType+checkOp :: (MonadFail m) => [VType] -> VType -> [OExpr] -> m VType checkOp tys rety args = do    argsty <- mapM inferType args   if tys == argsty      then return rety      else fail "" -inferType :: (Monad m) => OExpr -> m VType+inferType :: (MonadFail m) => OExpr -> m VType inferType (OInt _) = return VTInt inferType (OBool _) = return VTBool inferType (OPair x y) = liftM2 VTPair (inferType x) (inferType y)
compdata.cabal view
@@ -1,22 +1,17 @@ Name:			compdata-Version:		0.6.1.4+Version:		0.13.1 Synopsis:            	Compositional Data Types Description: -  Based on Wouter Swierstra's Functional Pearl /Data types a la carte/-  (Journal of Functional Programming, 18(4):423-436, 2008,-  <http://dx.doi.org/10.1017/S0956796808006758>),-  this package provides a framework for defining recursive-  data types in a compositional manner. The fundamental idea of-  /compositional data types/ (Workshop on Generic Programming, 83-94, 2011,-  <http://dx.doi.org/10.1145/2036918.2036930>) is to separate the-  signature of a data type-  from the fixed point construction that produces its recursive-  structure. By allowing to compose and decompose signatures,-  compositional data types enable to combine data types in a flexible-  way. The key point of Wouter Swierstra's original work is to define-  functions on compositional data types in a compositional manner as-  well by leveraging Haskell's type class machinery.+  This library implements the ideas of+  <http://dx.doi.org/10.1017/S0956796808006758 Data types a la carte>+  as outlined in the paper+  <http://dx.doi.org/10.1145/2036918.2036930 Compositional data types>. The+  purpose of this library is to allow the programmer to construct data+  types -- as well as the functions defined on them -- in a modular+  fashion. The underlying idea is to separate the signature of a data+  type from the fixed point construction that produces its recursive+  structure. Signatures can then be composed and decomposed freely.   .   Building on that foundation, this library provides additional   extensions and (run-time) optimisations which make compositional data types@@ -26,10 +21,14 @@   suited for programming language implementations, especially, in an environment   consisting of a family of tightly interwoven /domain-specific languages/.   .-  In concrete terms, this package provides the following features:+  In concrete terms, this library provides the following features:   .   *  Compositional data types in the style of Wouter Swierstra's-     Functional Pearl /Data types a la carte/.+     Functional Pearl /Data types a la carte/. The implementation of+     signature subsumption is based on the paper+     /Composing and Decomposing Data Types/ (Workshop on Generic+     Programming, 2014, to appear), which makes signature composition more+     flexible.   .   *  Modular definition of functions on compositional data types through      catamorphisms and anamorphisms as well as more structured@@ -69,209 +68,137 @@      to families of mutually recursive data types and (more generally) GADTs.      This extension resides in the module "Data.Comp.Multi".   .-  * /Parametric compositional data types/ (Workshop on Mathematically-     Structured Functional Programming, 3-24, 2012,-     <http://dx.doi.org/10.4204/EPTCS.76.3>). All of the above is also-     lifted to parametric data types, which enables support for-     parametric higher-order abstract syntax (PHOAS). This extension-     resides in the module "Data.Comp.Param".++  Examples of using (generalised) compositional data types are bundled+  with the package in the folder @examples@.   .-  *  /Generalised parametric compositional data types/. All of the above is also-     lifted to generalised parametric data types, which enables support for-     typed parametric higher-order abstract syntax (PHOAS). This extension-     resides in the module "Data.Comp.MultiParam".++  There are some supplementary packages, some of which were included+  in previous versions of this package:   .-  * Advanced recursion schemes derived from tree automata. These-    recursion schemes allow for a higher degree of modularity and make-    it possible to apply fusion. See /Modular Tree Automata/-    (Mathematics of Program Construction, 263-299, 2012,-    <http://dx.doi.org/10.1007/978-3-642-31113-0_14>).+  * <https://hackage.haskell.org/package/compdata-param compdata-param>:+    a parametric variant of compositional data types to deal with variable+    binders in a systematic way.   .+  * <https://hackage.haskell.org/package/compdata-automata compdata-automata>:+    advanced recursion schemes derived from tree automata that allow for a+    higher degree of modularity and make it possible to apply fusion.+  .+  * <https://hackage.haskell.org/package/compdata-dags compdata-dags>:+    recursion schemes on directed acyclic graphs. -  Examples of using (generalised) (parametric) compositional data types are-  bundled with the package in the libray @examples@. -Category:            	Generics-License:		BSD3-License-file:		LICENSE-Author:			Patrick Bahr, Tom Hvitved-Maintainer:		paba@diku.dk-Build-Type:		Simple+Category:               Generics+License:                BSD3+License-file:           LICENSE+Author:                 Patrick Bahr, Tom Hvitved+Maintainer:             paba@itu.dk+Build-Type:             Simple Cabal-Version:          >=1.9.2+bug-reports:            https://github.com/pa-ba/compdata/issues  extra-source-files:+  CHANGELOG.md   -- test files-  testsuite/tests/Data_Test.hs,-  testsuite/tests/Data/Comp_Test.hs,-  testsuite/tests/Data/Comp/Equality_Test.hs,-  testsuite/tests/Data/Comp/Variables_Test.hs,-  testsuite/tests/Data/Comp/Multi_Test.hs,-  testsuite/tests/Data/Comp/Multi/Variables_Test.hs,-  testsuite/tests/Data/Comp/Examples_Test.hs,-  testsuite/tests/Data/Comp/Examples/Comp.hs,-  testsuite/tests/Data/Comp/Examples/Multi.hs,-  testsuite/tests/Data/Comp/Examples/Param.hs,-  testsuite/tests/Data/Comp/Examples/MultiParam.hs,+  testsuite/tests/*.hs+  testsuite/tests/Data/*.hs+  testsuite/tests/Data/Comp/*.hs+  testsuite/tests/Data/Comp/Multi/*.hs+  testsuite/tests/Data/Comp/Examples/*.hs   testsuite/tests/Test/Utils.hs   -- benchmark files-  benchmark/Test.hs-  benchmark/Benchmark.hs-  benchmark/DataTypes.hs-  benchmark/Functions.hs-  benchmark/DataTypes/Comp.hs-  benchmark/DataTypes/Transform.hs-  benchmark/DataTypes/Standard.hs-  benchmark/Multi/DataTypes/Comp.hs-  benchmark/Multi/Functions/Comp/Eval.hs-  benchmark/Multi/Functions/Comp/Desugar.hs-  benchmark/Transformations.hs-  benchmark/Functions/Comp.hs-  benchmark/Functions/Comp/Eval.hs-  benchmark/Functions/Comp/Desugar.hs-  benchmark/Functions/Comp/FreeVars.hs-  benchmark/Functions/Comp/Inference.hs-  benchmark/Functions/Standard/Eval.hs-  benchmark/Functions/Standard/Desugar.hs-  benchmark/Functions/Standard/FreeVars.hs-  benchmark/Functions/Standard/Inference.hs-  benchmark/Functions/Standard.hs+  benchmark/*.hs+  benchmark/DataTypes/*.hs+  benchmark/Functions/*.hs+  benchmark/Functions/Comp/*.hs+  benchmark/Functions/Standard/*.hs+  benchmark/Multi/DataTypes/*.hs+  benchmark/Multi/Functions/Comp/*.hs   -- example files-  examples/Examples/Common.hs-  examples/Examples/Eval.hs-  examples/Examples/EvalM.hs-  examples/Examples/Desugar.hs-  examples/Examples/Automata/Compiler.hs,-  examples/Examples/Multi/Common.hs-  examples/Examples/Multi/Eval.hs-  examples/Examples/Multi/EvalI.hs-  examples/Examples/Multi/EvalM.hs-  examples/Examples/Multi/Desugar.hs-  examples/Examples/Param/Lambda.hs-  examples/Examples/Param/Names.hs-  examples/Examples/Param/Graph.hs-  examples/Examples/MultiParam/Lambda.hs-  examples/Examples/MultiParam/FOL.hs+  examples/Examples/*.hs+  examples/Examples/Multi/*.hs  library-  Exposed-Modules:      Data.Comp,-                        Data.Comp.Annotation,-                        Data.Comp.Sum,-                        Data.Comp.Term,-                        Data.Comp.Algebra,-                        Data.Comp.Equality,-                        Data.Comp.Ordering,-                        Data.Comp.DeepSeq,+  Exposed-Modules:      Data.Comp+                        Data.Comp.Annotation+                        Data.Comp.Sum+                        Data.Comp.Term+                        Data.Comp.Algebra+                        Data.Comp.Equality+                        Data.Comp.Ordering+                        Data.Comp.DeepSeq                         Data.Comp.Generic-                        Data.Comp.TermRewriting,-                        Data.Comp.Arbitrary,-                        Data.Comp.Show,-                        Data.Comp.Variables,-                        Data.Comp.Decompose,-                        Data.Comp.Unification,-                        Data.Comp.Derive,-                        Data.Comp.Matching,-                        Data.Comp.Desugar,-                        Data.Comp.Automata,-                        Data.Comp.Automata.Product,-                        Data.Comp.Number,-                        Data.Comp.Thunk,-                        Data.Comp.Ops,+                        Data.Comp.TermRewriting+                        Data.Comp.Arbitrary+                        Data.Comp.Show+                        Data.Comp.Render+                        Data.Comp.Variables+                        Data.Comp.Decompose+                        Data.Comp.Unification+                        Data.Comp.Derive+                        Data.Comp.Derive.Utils+                        Data.Comp.Matching+                        Data.Comp.Desugar+                        Data.Comp.Mapping+                        Data.Comp.Thunk+                        Data.Comp.Ops+                        Data.Comp.Projection -                        Data.Comp.Multi,-                        Data.Comp.Multi.Term,-                        Data.Comp.Multi.Sum,-                        Data.Comp.Multi.HFunctor,-                        Data.Comp.Multi.HFoldable,-                        Data.Comp.Multi.HTraversable,-                        Data.Comp.Multi.Algebra,-                        Data.Comp.Multi.Annotation,-                        Data.Comp.Multi.Show,-                        Data.Comp.Multi.Equality,-                        Data.Comp.Multi.Ordering,-                        Data.Comp.Multi.Variables,-                        Data.Comp.Multi.Ops,-                        Data.Comp.Multi.Number,+                        Data.Comp.Multi+                        Data.Comp.Multi.Term+                        Data.Comp.Multi.Sum+                        Data.Comp.Multi.HFunctor+                        Data.Comp.Multi.HFoldable+                        Data.Comp.Multi.HTraversable+                        Data.Comp.Multi.Algebra+                        Data.Comp.Multi.Annotation+                        Data.Comp.Multi.Show+                        Data.Comp.Multi.Equality+                        Data.Comp.Multi.Ordering+                        Data.Comp.Multi.Variables+                        Data.Comp.Multi.Ops+                        Data.Comp.Multi.Mapping                         Data.Comp.Multi.Derive-                        Data.Comp.Multi.Generic,-                        Data.Comp.Multi.Desugar,--                        Data.Comp.Param,-                        Data.Comp.Param.Term,-                        Data.Comp.Param.FreshM,-                        Data.Comp.Param.Sum,-                        Data.Comp.Param.Difunctor,-                        Data.Comp.Param.Ditraversable,-                        Data.Comp.Param.Algebra,-                        Data.Comp.Param.Annotation,-                        Data.Comp.Param.Ops-                        Data.Comp.Param.Equality-                        Data.Comp.Param.Ordering-                        Data.Comp.Param.Show-                        Data.Comp.Param.Derive,-                        Data.Comp.Param.Desugar-                        Data.Comp.Param.Thunk--                        Data.Comp.MultiParam,-                        Data.Comp.MultiParam.Term,-                        Data.Comp.MultiParam.FreshM,-                        Data.Comp.MultiParam.Sum,-                        Data.Comp.MultiParam.HDifunctor,-                        Data.Comp.MultiParam.HDitraversable,-                        Data.Comp.MultiParam.Algebra,-                        Data.Comp.MultiParam.Annotation,-                        Data.Comp.MultiParam.Ops-                        Data.Comp.MultiParam.Equality-                        Data.Comp.MultiParam.Ordering-                        Data.Comp.MultiParam.Show-                        Data.Comp.MultiParam.Derive,-                        Data.Comp.MultiParam.Desugar+                        Data.Comp.Multi.Generic+                        Data.Comp.Multi.Desugar+                        Data.Comp.Multi.Projection -  Other-Modules:        Data.Comp.Derive.Utils,-                        Data.Comp.Derive.Equality,-                        Data.Comp.Derive.Ordering,-                        Data.Comp.Derive.Arbitrary,-                        Data.Comp.Derive.Show,-                        Data.Comp.Derive.DeepSeq,-                        Data.Comp.Derive.SmartConstructors,-                        Data.Comp.Derive.SmartAConstructors,-                        Data.Comp.Derive.Foldable,-                        Data.Comp.Derive.Traversable,-                        Data.Comp.Derive.Injections,-                        Data.Comp.Derive.Projections,-                        Data.Comp.Derive.HaskellStrict,-                        Data.Comp.Automata.Product.Derive,+  Other-Modules:        Data.Comp.SubsumeCommon+                        Data.Comp.Derive.Equality+                        Data.Comp.Derive.Ordering+                        Data.Comp.Derive.Arbitrary+                        Data.Comp.Derive.Show+                        Data.Comp.Derive.DeepSeq+                        Data.Comp.Derive.SmartConstructors+                        Data.Comp.Derive.SmartAConstructors+                        Data.Comp.Derive.Foldable+                        Data.Comp.Derive.Traversable+                        Data.Comp.Derive.HaskellStrict -                        Data.Comp.Multi.Derive.HFunctor,-                        Data.Comp.Multi.Derive.HFoldable,-                        Data.Comp.Multi.Derive.HTraversable,-                        Data.Comp.Multi.Derive.Equality,-                        Data.Comp.Multi.Derive.Ordering,-                        Data.Comp.Multi.Derive.Show,+                        Data.Comp.Multi.Derive.HFunctor+                        Data.Comp.Multi.Derive.HFoldable+                        Data.Comp.Multi.Derive.HTraversable+                        Data.Comp.Multi.Derive.Equality+                        Data.Comp.Multi.Derive.Ordering+                        Data.Comp.Multi.Derive.Show                         Data.Comp.Multi.Derive.SmartConstructors                         Data.Comp.Multi.Derive.SmartAConstructors-                        Data.Comp.Multi.Derive.Injections,-                        Data.Comp.Multi.Derive.Projections, -                        Data.Comp.Param.Derive.Difunctor,-                        Data.Comp.Param.Derive.Ditraversable,-                        Data.Comp.Param.Derive.Equality,-                        Data.Comp.Param.Derive.Ordering,-                        Data.Comp.Param.Derive.Show,-                        Data.Comp.Param.Derive.SmartConstructors,-                        Data.Comp.Param.Derive.SmartAConstructors,-                        Data.Comp.Param.Derive.Injections,-                        Data.Comp.Param.Derive.Projections, -                        Data.Comp.MultiParam.Derive.HDifunctor,-                        Data.Comp.MultiParam.Derive.Equality,-                        Data.Comp.MultiParam.Derive.Ordering,-                        Data.Comp.MultiParam.Derive.Show,-                        Data.Comp.MultiParam.Derive.SmartConstructors,-                        Data.Comp.MultiParam.Derive.SmartAConstructors,-                        Data.Comp.MultiParam.Derive.Injections,-                        Data.Comp.MultiParam.Derive.Projections -  Build-Depends:	base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, th-expand-syns, transformers++  Build-Depends:        base >= 4.16 && < 4.19,+                        QuickCheck >= 2.14.3 && < 2.15,+                        containers >= 0.6.8 && < 0.7,+                        deepseq >= 1.4 && < 1.6,+                        template-haskell >= 2.17 && < 2.22,+                        mtl >= 2.3.1 && < 2.4,+                        transformers >= 0.6.1 && < 0.7,+                        th-expand-syns >= 0.4.11 && < 0.5,+                        tree-view >= 0.5.1 && < 0.6++  Default-Language:     Haskell2010+  Default-Extensions:   FlexibleContexts   hs-source-dirs:	src   ghc-options:          -W @@ -279,9 +206,89 @@ Test-Suite test   Type:                 exitcode-stdio-1.0   Main-is:		Data_Test.hs-  hs-source-dirs:	src testsuite/tests examples-  Build-Depends:        base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, HUnit, test-framework, test-framework-hunit, test-framework-quickcheck2, derive, th-expand-syns, deepseq, transformers+  hs-source-dirs:	testsuite/tests examples src+  Build-Depends:        base >= 4.16 && < 5, template-haskell, containers, mtl >= 2.2.1,+                        QuickCheck >= 2, HUnit, test-framework, test-framework-hunit,+                        test-framework-quickcheck2 >= 0.3, deepseq, transformers, th-expand-syns+  Default-Language:     Haskell2010 +  ghc-options:          -W -Wno-incomplete-patterns+  Other-Modules:+        Data.Comp+        Data.Comp.Algebra+        Data.Comp.Annotation+        Data.Comp.Arbitrary+        Data.Comp.Derive+        Data.Comp.Derive.Arbitrary+        Data.Comp.Derive.DeepSeq+        Data.Comp.Derive.Equality+        Data.Comp.Derive.Foldable+        Data.Comp.Derive.HaskellStrict+        Data.Comp.Derive.Ordering+        Data.Comp.Derive.Show+        Data.Comp.Derive.SmartAConstructors+        Data.Comp.Derive.SmartConstructors+        Data.Comp.Derive.Traversable+        Data.Comp.Derive.Utils+        Data.Comp.Desugar+        Data.Comp.Equality+        Data.Comp.Equality_Test+        Data.Comp.Examples.Comp+        Data.Comp.Examples.Multi+        Data.Comp.Examples_Test+        Data.Comp.Generic+        Data.Comp.Mapping+        Data.Comp.Multi+        Data.Comp.Multi.Algebra+        Data.Comp.Multi.Annotation+        Data.Comp.Multi.Derive+        Data.Comp.Multi.Derive.Equality+        Data.Comp.Multi.Derive.HFoldable+        Data.Comp.Multi.Derive.HFunctor+        Data.Comp.Multi.Derive.HTraversable+        Data.Comp.Multi.Derive.Ordering+        Data.Comp.Multi.Derive.Show+        Data.Comp.Multi.Derive.SmartAConstructors+        Data.Comp.Multi.Derive.SmartConstructors+        Data.Comp.Multi.Desugar+        Data.Comp.Multi.Equality+        Data.Comp.Multi.Generic+        Data.Comp.Multi.HFoldable+        Data.Comp.Multi.HFunctor+        Data.Comp.Multi.HTraversable+        Data.Comp.Multi.Mapping+        Data.Comp.Multi.Ops+        Data.Comp.Multi.Ordering+        Data.Comp.Multi.Show+        Data.Comp.Multi.Sum+        Data.Comp.Multi.Term+        Data.Comp.Multi.Variables+        Data.Comp.Multi.Variables_Test+        Data.Comp.Multi_Test+        Data.Comp.Ops+        Data.Comp.Ordering+        Data.Comp.Show+        Data.Comp.SubsumeCommon+        Data.Comp.Subsume_Test+        Data.Comp.Sum+        Data.Comp.Term+        Data.Comp.Thunk+        Data.Comp.Variables+        Data.Comp.Variables_Test+        Data.Comp_Test+        Examples.Common+        Examples.Desugar+        Examples.Eval+        Examples.EvalM+        Examples.Thunk+        Examples.Multi.Common+        Examples.Multi.Desugar+        Examples.Multi.Eval+        Examples.Multi.EvalI+        Examples.Multi.EvalM+        Test.Utils++                           Benchmark algebra   Type:                 exitcode-stdio-1.0   Main-is:		Benchmark.hs@@ -289,9 +296,55 @@   ghc-options:          -W -O2   -- Disable short-cut fusion rules in order to compare optimised and unoptimised code.   cpp-options:          -DNO_RULES-  Build-Depends:        base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns, transformers-+  Build-Depends:        base >= 4.16 && < 5, template-haskell, containers, mtl >= 2.2.1,+                        QuickCheck >= 2, deepseq, criterion, random, uniplate, transformers,+                        th-expand-syns+  Default-Language:     Haskell2010+  Other-Modules:+        Data.Comp+        Data.Comp.Algebra+        Data.Comp.Annotation+        Data.Comp.Arbitrary+        Data.Comp.DeepSeq+        Data.Comp.Derive+        Data.Comp.Derive.Arbitrary+        Data.Comp.Derive.DeepSeq+        Data.Comp.Derive.Equality+        Data.Comp.Derive.Foldable+        Data.Comp.Derive.HaskellStrict+        Data.Comp.Derive.Ordering+        Data.Comp.Derive.Show+        Data.Comp.Derive.SmartAConstructors+        Data.Comp.Derive.SmartConstructors+        Data.Comp.Derive.Traversable+        Data.Comp.Derive.Utils+        Data.Comp.Equality+        Data.Comp.Generic+        Data.Comp.Mapping+        Data.Comp.Ops+        Data.Comp.Ordering+        Data.Comp.Show+        Data.Comp.SubsumeCommon+        Data.Comp.Sum+        Data.Comp.Term+        Data.Comp.Thunk+        Data.Comp.Variables+        DataTypes+        DataTypes.Comp+        DataTypes.Standard+        DataTypes.Transform+        Functions.Comp+        Functions.Comp.Desugar+        Functions.Comp.Eval+        Functions.Comp.FreeVars+        Functions.Comp.Inference+        Functions.Standard+        Functions.Standard.Desugar+        Functions.Standard.Eval+        Functions.Standard.FreeVars+        Functions.Standard.Inference  source-repository head-  type:     hg-  location: https://bitbucket.org/paba/compdata+  type:     git+  location: https://github.com/pa-ba/compdata+
− examples/Examples/Automata/Compiler.hs 
@@ -1,192 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleContexts, MultiParamTypeClasses,-TypeOperators, FlexibleInstances, UndecidableInstances,-ScopedTypeVariables, TypeSynonymInstances, GeneralizedNewtypeDeriving,-OverlappingInstances #-}--module Examples.Automata.Compiler where--import Data.Comp.Automata-import Data.Comp.Derive-import Data.Comp.Ops-import Data.Comp hiding (height)-import Data.Foldable-import Prelude hiding (foldl)--import Data.Set (Set, union, singleton, delete, member)-import qualified Data.Set as Set--import Data.Map (Map)-import qualified Data.Map as Map--type Var = String--data Val a = Const Int-data Op a  = Plus a a-           | Times a a-type Core = Op :+: Val-data Let a = Let Var a a-           | Var Var--type CoreLet = Let :+: Core--data Sugar a = Neg a-             | Minus a a--$(derive [makeFunctor, makeFoldable, makeTraversable, smartConstructors, makeShowF]-  [''Val, ''Op, ''Let, ''Sugar])---class Eval f where-    evalSt :: UpState f Int--$(derive [liftSum] [''Eval])--instance Eval Val where-    evalSt (Const i) = i--instance Eval Op where-    evalSt (Plus x y) = x + y-    evalSt (Times x y) = x * y--type Addr = Int--data Instr = Acc Int-           | Load Addr-           | Store Addr-           | Add Int-           | Sub Int-           | Mul Int-             deriving (Show)--type Code = [Instr]--data MState = MState {-      mRam :: Map Addr Int,-      mAcc :: Int }--runCode :: Code -> MState -> MState-runCode [] = id-runCode (ins:c) = runCode c . step ins -    where step (Acc i) s = s{mAcc = i}-          step (Load a) s = case Map.lookup a (mRam s) of-              Nothing -> error $ "memory cell " ++ show a ++ " is not set"-              Just n -> s {mAcc = n}-          step (Store a) s = s {mRam = Map.insert a (mAcc s) (mRam s)}-          step (Add a) s = exec (+) a s-          step (Sub a) s = exec (-) a s-          step (Mul a) s = exec (*) a s-          exec op a s = case Map.lookup a (mRam s) of-                        Nothing -> error $ "memory cell " ++ show a ++ " is not set"-                        Just n -> s {mAcc = mAcc s `op` n}---runCode' :: Code -> Int-runCode' c = mAcc $ runCode c MState{mRam = Map.empty, mAcc = error "accumulator is not set"}----- | Defines the height of an expression.-heightSt :: Foldable f => UpState f Int-heightSt t = foldl max 0 t + 1--tmpAddrSt :: Foldable f => UpState f Int-tmpAddrSt = (+1) . heightSt---newtype VarAddr = VarAddr {varAddr :: Int} deriving (Eq, Show, Num)--class VarAddrSt f where-  varAddrSt :: DownState f VarAddr-  -instance (VarAddrSt f, VarAddrSt g) => VarAddrSt (f :+: g) where-    varAddrSt (q,Inl x) = varAddrSt (q, x)-    varAddrSt (q,Inr x) = varAddrSt (q, x)--instance VarAddrSt Let where-  varAddrSt (d, Let _ _ x) = x `Map.singleton` (d + 2)-  varAddrSt _ = Map.empty-  -instance VarAddrSt f where-  varAddrSt _ = Map.empty---type Bind = Map Var Int--bindSt :: (Let :<: f,VarAddr :< q) => DDownState f q Bind-bindSt t = case proj t of-             Just (Let v _ e) -> Map.singleton e q'-                       where q' = Map.insert v (varAddr above) above-             _ -> Map.empty---- | Defines the code that an expression is compiled to. It depends on--- an integer state that denotes the height of the current node.-class CodeSt f q where-    codeSt :: DUpState f q Code--instance (CodeSt f q, CodeSt g q) => CodeSt (f :+: g) q where-    codeSt (Inl x) = codeSt x-    codeSt (Inr x) = codeSt x-  --instance CodeSt Val q where-    codeSt (Const i) = [Acc i]--instance (Int :< q) => CodeSt Op q where-    codeSt (Plus x y) = below x ++ [Store i] ++ below y ++ [Add i]-        where i = below y-    codeSt (Times x y) = below x ++ [Store i] ++ below y ++ [Mul i]-        where i = below y--instance (VarAddr :< q, Bind :< q) => CodeSt Let q where-    codeSt (Let _ b e) = below b ++ [Store i] ++ below e-                    where i = varAddr above-    codeSt (Var v) = case Map.lookup v above of-                       Nothing -> error $ "unbound variable " ++ v-                       Just i -> [Load i]--compile' :: (CodeSt f (Code,Int), Foldable f, Functor f) => Term f -> Code-compile' = fst . runDUpState (codeSt `prodDUpState` dUpState tmpAddrSt)---exComp' = compile' (iConst 2 `iPlus` iConst 3 :: Term Core)----compile :: (CodeSt f ((Code,Int),(Bind,VarAddr)), Traversable f, Functor f, Let :<: f, VarAddrSt f)-           => Term f -> Code-compile = fst . runDState -          (codeSt `prodDUpState` dUpState tmpAddrSt)-          (bindSt `prodDDownState` dDownState varAddrSt)-          (Map.empty, VarAddr 1)-          --exComp = compile (iLet "x" (iLet "x" (iConst 5) (iConst 10 `iPlus` iVar "x")) (iConst 2 `iPlus` iVar "x") :: Term CoreLet)---- | Defines the set of free variables-class VarsSt f where-    varsSt :: UpState f (Set Var)--$(derive [liftSum] [''VarsSt])--instance VarsSt Val where-    varsSt _ = Set.empty--instance VarsSt Op where-    varsSt (Plus x y) = x `union` y-    varsSt (Times x y) = x `union` y--instance VarsSt Let where-    varsSt (Var v) = singleton v-    varsSt (Let v x y) = (if v `member` y then x else Set.empty) `union` delete v y---- | Stateful homomorphism that removes unnecessary let bindings.-remLetHom :: (Set Var :< q, Let :<: f, Functor f) => QHom f q f-remLetHom t = case proj t of-                Just (Let v _ y) -                    | not (v `member` below y) -> Hole y-                _ -> simpCxt t---- | Removes unnecessary let bindings.-remLet :: (Let :<: f, Functor f, VarsSt f) => Term f -> Term f-remLet = runUpHom varsSt remLetHom--exLet = remLet (iLet "x" (iConst 3) (iConst 2 `iPlus` iVar "y") :: Term CoreLet)
examples/Examples/Common.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFunctor #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Common@@ -21,12 +23,14 @@  -- Signature for values and operators data Value a = Const Int | Pair a a+  deriving Functor data Op a    = Add a a | Mult a a | Fst a | Snd a+  deriving Functor  -- Signature for the simple expression language type Sig = Op :+: Value  -- Derive boilerplate code using Template Haskell-$(derive [makeFunctor, makeTraversable, makeFoldable,+$(derive [makeTraversable, makeFoldable,           makeEqF, makeShowF, smartConstructors, smartAConstructors]          [''Value, ''Op])
examples/Examples/Desugar.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances #-}+  ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Desugar@@ -31,6 +32,7 @@  -- Signature for syntactic sugar data Sugar a = Neg a | Swap a+  deriving Functor  -- Source position information (line number, column number) data Pos = Pos Int Int@@ -47,7 +49,7 @@ type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos  -- Derive boilerplate code using Template Haskell-$(derive [makeFunctor, makeTraversable, makeFoldable,+$(derive [makeTraversable, makeFoldable,           makeEqF, makeShowF, makeOrdF, smartConstructors, smartAConstructors]          [''Sugar])
examples/Examples/Eval.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Eval@@ -35,10 +35,10 @@ eval :: (Functor f, Eval f v) => Term f -> Term v eval = cata evalAlg -instance (f :<: v) => Eval f v where+instance {-# OVERLAPPABLE #-} (f :<: v) => Eval f v where   evalAlg = inject -- default instance -instance (Value :<: v) => Eval Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => Eval Op v where   evalAlg (Add x y)  = iConst $ projC x + projC y   evalAlg (Mult x y) = iConst $ projC x * projC y   evalAlg (Fst x)    = fst $ projP x
examples/Examples/EvalM.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.EvalM@@ -35,10 +35,10 @@ evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v) evalM = cataM evalAlgM -instance (f :<: v) => EvalM f v where+instance {-# OVERLAPPABLE #-} (f :<: v) => EvalM f v where   evalAlgM = return . inject -- default instance -instance (Value :<: v) => EvalM Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => EvalM Op v where   evalAlgM (Add x y)  = do n1 <- projC x                            n2 <- projC y                            return $ iConst $ n1 + n2
examples/Examples/Multi/Desugar.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,-  IncoherentInstances #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Multi.Desugar
examples/Examples/Multi/Eval.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,-  OverlappingInstances #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Multi.Eval@@ -34,10 +34,10 @@ eval :: (HFunctor f, Eval f v) => Term f :-> Term v eval = cata evalAlg -instance (f :<: v) => Eval f v where+instance  {-# OVERLAPPABLE #-} (f :<: v) => Eval f v where   evalAlg = inject -- default instance -instance (Value :<: v) => Eval Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => Eval Op v where   evalAlg (Add x y)  = iConst $ projC x + projC y   evalAlg (Mult x y) = iConst $ projC x * projC y   evalAlg (Fst x)    = fst $ projP x
examples/Examples/Multi/EvalM.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,   FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,-  OverlappingInstances #-}+  ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module      :  Examples.Multi.EvalM@@ -34,10 +34,10 @@ evalM :: (HTraversable f, EvalM f v) => Term f i -> Maybe (Term v i) evalM = cataM evalAlgM -instance (f :<: v) => EvalM f v where+instance {-# OVERLAPPABLE #-} (f :<: v) => EvalM f v where   evalAlgM = return . inject -- default instance -instance (Value :<: v) => EvalM Op v where+instance {-# OVERLAPPABLE #-} (Value :<: v) => EvalM Op v where   evalAlgM (Add x y)  = do n1 <- projC x                            n2 <- projC y                            return $ iConst $ n1 + n2
− examples/Examples/MultiParam/FOL.hs 
@@ -1,436 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleInstances,-  FlexibleContexts, UndecidableInstances, GADTs, KindSignatures,-  OverlappingInstances, TypeSynonymInstances, EmptyDataDecls #-}------------------------------------------------------------------------------------ |--- Module      :  Examples.MultiParam.FOL--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ First-Order Logic a la Carte------ This example illustrates how to implement First-Order Logic a la Carte--- (Knowles, The Monad.Reader Issue 11, '08) using Generalised Parametric--- Compositional Data Types.------ Rather than using a fixed domain 'Term' for binders as Knowles, our encoding--- uses a mutually recursive data structure for terms and formulae. This makes--- terms modular too, and hence we only introduce variables when they are--- actually needed in stage 5.--------------------------------------------------------------------------------------module Examples.MultiParam.FOL where--import Data.Comp.MultiParam hiding (Var)-import qualified Data.Comp.MultiParam as MP-import Data.Comp.MultiParam.Show ()-import Data.Comp.MultiParam.Derive-import Data.Comp.MultiParam.FreshM (Name, withName, evalFreshM)-import Data.List (intercalate)-import Data.Maybe-import Control.Monad.State-import Control.Monad.Reader---- Phantom types indicating whether a (recursive) term is a formula or a term-data TFormula-data TTerm---- Terms-data Const :: (* -> *) -> (* -> *) -> * -> * where-    Const :: String -> [e TTerm] -> Const a e TTerm-data Var :: (* -> *) -> (* -> *) -> * -> * where-    Var :: String -> Var a e TTerm---- Formulae-data TT :: (* -> *) -> (* -> *) -> * -> * where-    TT :: TT a e TFormula-data FF :: (* -> *) -> (* -> *) -> * -> * where-    FF :: FF a e TFormula-data Atom :: (* -> *) -> (* -> *) -> * -> * where-    Atom :: String -> [e TTerm] -> Atom a e TFormula-data NAtom :: (* -> *) -> (* -> *) -> * -> * where-    NAtom :: String -> [e TTerm] -> NAtom a e TFormula-data Not :: (* -> *) -> (* -> *) -> * -> * where-    Not :: e TFormula -> Not a e TFormula-data Or :: (* -> *) -> (* -> *) -> * -> * where-    Or :: e TFormula -> e TFormula -> Or a e TFormula-data And :: (* -> *) -> (* -> *) -> * -> * where-    And :: e TFormula -> e TFormula -> And a e TFormula-data Impl :: (* -> *) -> (* -> *) -> * -> * where-    Impl :: e TFormula -> e TFormula -> Impl a e TFormula-data Exists :: (* -> *) -> (* -> *) -> * -> * where-    Exists :: (a TTerm -> e TFormula) -> Exists a e TFormula-data Forall :: (* -> *) -> (* -> *) -> * -> * where-    Forall :: (a TTerm -> e TFormula) -> Forall a e TFormula--$(derive [makeHDifunctor, smartConstructors]-         [''Const, ''Var, ''TT, ''FF, ''Atom, ''NAtom,-          ''Not, ''Or, ''And, ''Impl, ''Exists, ''Forall])------------------------------------------------------------------------------------- (Custom) pretty printing of terms and formulae-----------------------------------------------------------------------------------instance ShowHD Const where-  showHD (Const f t) = do ts <- mapM unK t-                          return $ f ++ "(" ++ intercalate ", " ts ++ ")"--instance ShowHD Var where-  showHD (Var x) = return x--instance ShowHD TT where-  showHD TT = return "true"--instance ShowHD FF where-  showHD FF = return "false"--instance ShowHD Atom where-  showHD (Atom p t) = do ts <- mapM unK t-                         return $ p ++ "(" ++ intercalate ", " ts ++ ")"--instance ShowHD NAtom where-  showHD (NAtom p t) = do ts <- mapM unK t-                          return $ "not " ++ p ++ "(" ++ intercalate ", " ts ++ ")"--instance ShowHD Not where-  showHD (Not (K f)) = liftM (\x -> "not (" ++ x ++ ")") f--instance ShowHD Or where-  showHD (Or (K f1) (K f2)) =-      liftM2 (\x y -> "(" ++ x ++ ") or (" ++ y ++ ")") f1 f2--instance ShowHD And where-  showHD (And (K f1) (K f2)) =-      liftM2 (\x y -> "(" ++ x ++ ") and (" ++ y ++ ")") f1 f2--instance ShowHD Impl where-  showHD (Impl (K f1) (K f2)) =-      liftM2 (\x y -> "(" ++ x ++ ") -> (" ++ y ++ ")") f1 f2--instance ShowHD Exists where-  showHD (Exists f) =-      withName (\x -> do b <- unK (f x)-                         return $ "exists " ++ show x ++ ". " ++ b)--instance ShowHD Forall where-  showHD (Forall f) =-      withName (\x -> do b <- unK (f x)-                         return $ "forall " ++ show x ++ ". " ++ b)------------------------------------------------------------------------------------- Stage 0-----------------------------------------------------------------------------------type Input = Const :+:-             TT :+: FF :+: Atom :+: Not :+: Or :+: And :+: Impl :+:-             Exists :+: Forall--foodFact :: Term Input TFormula-foodFact = Term $-  iExists (\p -> iAtom "Person" [p] `iAnd`-                 iForall (\f -> iAtom "Food" [f] `iImpl`-                                iAtom "Eats" [p,f])) `iImpl`-  iNot (iExists $ \f -> iAtom "Food" [f] `iAnd`-                        iNot (iExists $ \p -> iAtom "Person" [p] `iAnd`-                                              iAtom "Eats" [p,f]))------------------------------------------------------------------------------------- Stage 1: Eliminate Implications-----------------------------------------------------------------------------------type Stage1 = Const :+:-              TT :+: FF :+: Atom :+: Not :+: Or :+: And :+: Exists :+: Forall--class HDifunctor f => ElimImp f where-  elimImpHom :: Hom f Stage1--$(derive [liftSum] [''ElimImp])--elimImp :: Term Input :-> Term Stage1-elimImp (Term t) = Term (appHom elimImpHom t)--instance (HDifunctor f, f :<: Stage1) => ElimImp f where-  elimImpHom = simpCxt . inj--instance ElimImp Impl where-  elimImpHom (Impl f1 f2) = iNot (Hole f1) `iOr` (Hole f2)--foodFact1 :: Term Stage1 TFormula-foodFact1 = elimImp foodFact------------------------------------------------------------------------------------- Stage 2: Move Negation Inwards-----------------------------------------------------------------------------------type Stage2 = Const :+:-              TT :+: FF :+: Atom :+: NAtom :+: Or :+: And :+: Exists :+: Forall--class HDifunctor f => Dualize f where-  dualizeHom :: f a (Cxt h Stage2 a b) :-> Cxt h Stage2 a b--$(derive [liftSum] [''Dualize])--dualize :: Trm Stage2 a :-> Trm Stage2 a-dualize = appHom (dualizeHom . hfmap Hole)--instance Dualize Const where-  dualizeHom (Const f t) = iConst f t--instance Dualize TT where-  dualizeHom TT = iFF--instance Dualize FF where-  dualizeHom FF = iTT--instance Dualize Atom where-  dualizeHom (Atom p t) = iNAtom p t--instance Dualize NAtom where-  dualizeHom (NAtom p t) = iAtom p t--instance Dualize Or where-  dualizeHom (Or f1 f2) = f1 `iAnd` f2--instance Dualize And where-  dualizeHom (And f1 f2) = f1 `iOr` f2--instance Dualize Exists where-  dualizeHom (Exists f) = inject $ Forall f--instance Dualize Forall where-  dualizeHom (Forall f) = inject $ Exists f--class PushNot f where-  pushNotAlg :: Alg f (Trm Stage2 a)--$(derive [liftSum] [''PushNot])--pushNotInwards :: Term Stage1 :-> Term Stage2-pushNotInwards t = Term (cata pushNotAlg t)--instance (HDifunctor f, f :<: Stage2) => PushNot f where-  pushNotAlg = inject . hdimap MP.Var id -- default--instance PushNot Not where-  pushNotAlg (Not f) = dualize f--foodFact2 :: Term Stage2 TFormula-foodFact2 = pushNotInwards foodFact1------------------------------------------------------------------------------------- Stage 4: Skolemization-----------------------------------------------------------------------------------type Stage4 = Const :+:-              TT :+: FF :+: Atom :+: NAtom :+: Or :+: And :+: Forall--type Unique = Int-data UniqueSupply = UniqueSupply Unique UniqueSupply UniqueSupply--initialUniqueSupply :: UniqueSupply-initialUniqueSupply = genSupply 1-    where genSupply n = UniqueSupply n (genSupply (2 * n))-                                       (genSupply (2 * n + 1))--splitUniqueSupply :: UniqueSupply -> (UniqueSupply, UniqueSupply)-splitUniqueSupply (UniqueSupply	_ l r) = (l,r)--getUnique :: UniqueSupply -> (Unique, UniqueSupply)-getUnique (UniqueSupply n l _) = (n,l)--type Supply = State UniqueSupply-type S a = ReaderT [Trm Stage4 a TTerm] Supply--evalS :: S a b -> [Trm Stage4 a TTerm] -> UniqueSupply -> b-evalS m env = evalState (runReaderT m env)--fresh :: S a Int-fresh = do supply <- get-           let (uniq,rest) = getUnique supply-           put rest-           return uniq--freshes :: S a UniqueSupply-freshes = do supply <- get-             let (l,r) = splitUniqueSupply supply-             put r-             return l--class Skolem f where-  skolemAlg :: AlgM' (S a) f (Trm Stage4 a)--$(derive [liftSum] [''Skolem])--skolemize :: Term Stage2 :-> Term Stage4-skolemize f = Term (evalState (runReaderT (cataM' skolemAlg f) [])-                              initialUniqueSupply)--instance Skolem Const where-  skolemAlg (Const f t) = liftM (iConst f) $ mapM getCompose t--instance Skolem TT where-  skolemAlg TT = return iTT--instance Skolem FF where-  skolemAlg FF = return iFF--instance Skolem Atom where-  skolemAlg (Atom p t) = liftM (iAtom p) $ mapM getCompose t--instance Skolem NAtom where-  skolemAlg (NAtom p t) = liftM (iNAtom p) $ mapM getCompose t--instance Skolem Or where-  skolemAlg (Or (Compose f1) (Compose f2)) = liftM2 iOr f1 f2--instance Skolem And where-  skolemAlg (And (Compose f1) (Compose f2)) = liftM2 iAnd f1 f2--instance Skolem Forall where-  skolemAlg (Forall f) = do-    supply <- freshes-    xs <- ask-    return $ iForall $ \x -> evalS (getCompose $ f x) (x : xs) supply--instance Skolem Exists where-  skolemAlg (Exists f) = do-    uniq <- fresh-    xs <- ask-    getCompose $ f (iConst ("Skol" ++ show uniq) xs)--foodFact4 :: Term Stage4 TFormula-foodFact4 = skolemize foodFact2------------------------------------------------------------------------------------- Stage 5: Prenex Normal Form-----------------------------------------------------------------------------------type Stage5 = Const :+: Var :+:-              TT :+: FF :+: Atom :+: NAtom :+: Or :+: And--class Prenex f where-  prenexAlg :: AlgM' (S a) f (Trm Stage5 a)--$(derive [liftSum] [''Prenex])--prenex :: Term Stage4 :-> Term Stage5-prenex f = Term (evalState (runReaderT (cataM' prenexAlg f) [])-                           initialUniqueSupply)--instance Prenex Const where-  prenexAlg (Const f t) = liftM (iConst f) $ mapM getCompose t--instance Prenex TT where-  prenexAlg TT = return iTT--instance Prenex FF where-  prenexAlg FF = return iFF--instance Prenex Atom where-  prenexAlg (Atom p t) = liftM (iAtom p) $ mapM getCompose t--instance Prenex NAtom where-  prenexAlg (NAtom p t) = liftM (iNAtom p) $ mapM getCompose t--instance Prenex Or where-  prenexAlg (Or (Compose f1) (Compose f2)) = liftM2 iOr f1 f2--instance Prenex And where-  prenexAlg (And (Compose f1) (Compose f2)) = liftM2 iAnd f1 f2--instance Prenex Forall where-  prenexAlg (Forall f) = do uniq <- fresh-                            getCompose $ f (iVar ('x' : show uniq))--foodFact5 :: Term Stage5 TFormula-foodFact5 = prenex foodFact4------------------------------------------------------------------------------------- Stage 6: Conjunctive Normal Form-----------------------------------------------------------------------------------type Literal a     = Trm (Const :+: Var :+: Atom :+: NAtom) a-newtype Clause a i = Clause {unClause :: [Literal a i]} -- implicit disjunction-newtype CNF a i    = CNF {unCNF :: [Clause a i]}        -- implicit conjunction--instance (HDifunctor f, ShowHD f) => Show (Trm f Name i) where-  show = evalFreshM . showHD . toCxt--instance Show (Clause Name i) where-  show c = intercalate " or " $ map show $ unClause c--instance Show (CNF Name i) where-  show c = intercalate "\n" $ map show $ unCNF c--class ToCNF f where-  cnfAlg :: f (CNF a) (CNF a) i -> [Clause a i]--$(derive [liftSum] [''ToCNF])--cnf :: Term Stage5 :-> CNF a-cnf = cata (CNF . cnfAlg)--instance ToCNF Const where-  cnfAlg (Const f t) =-      [Clause [iConst f (map (head . unClause . head . unCNF) t)]]--instance ToCNF Var where-  cnfAlg (Var x) = [Clause [iVar x]]--instance ToCNF TT where-  cnfAlg TT = []--instance ToCNF FF where-  cnfAlg FF = [Clause []]--instance ToCNF Atom where-  cnfAlg (Atom p t) =-      [Clause [iAtom p (map (head . unClause . head . unCNF) t)]]--instance ToCNF NAtom where-  cnfAlg (NAtom p t) =-      [Clause [iNAtom p (map (head . unClause . head . unCNF) t)]]--instance ToCNF And where-  cnfAlg (And f1 f2) = unCNF f1 ++ unCNF f2--instance ToCNF Or where-  cnfAlg (Or f1 f2) =-      [Clause (x ++ y) | Clause x <- unCNF f1, Clause y <- unCNF f2]--foodFact6 :: CNF a TFormula-foodFact6 = cnf foodFact5------------------------------------------------------------------------------------- Stage 7: Implicative Normal Form-----------------------------------------------------------------------------------type T              = Const :+: Var :+: Atom :+: NAtom-newtype IClause a i = IClause ([Trm T a i], -- implicit conjunction-                               [Trm T a i]) -- implicit disjunction-newtype INF a i     = INF [IClause a i]     -- implicit conjunction--instance Show (IClause Name i) where-  show (IClause (cs,ds)) = let cs' = intercalate " and " $ map show cs-                               ds' = intercalate " or " $ map show ds-                           in "(" ++ cs' ++ ") -> (" ++ ds' ++ ")"--instance Show (INF Name i) where-  show (INF fs) = intercalate "\n" $ map show fs--inf :: CNF a TFormula -> INF a TFormula-inf (CNF f) = INF $ map (toImpl . unClause) f-    where toImpl :: [Literal a TFormula] -> IClause a TFormula-          toImpl disj = IClause ([iAtom p t | NAtom p t <- mapMaybe proj1 disj],-                                 [inject t | t <- mapMaybe proj2 disj])-          proj1 :: NatM Maybe (Trm T a) (NAtom a (Trm T a))-          proj1 = project-          proj2 :: NatM Maybe (Trm T a) (Atom a (Trm T a))-          proj2 = project--foodFact7 :: INF a TFormula-foodFact7 = inf foodFact6
− examples/Examples/MultiParam/Lambda.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,-  FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances, Rank2Types, GADTs, KindSignatures,-  ScopedTypeVariables, TypeFamilies #-}------------------------------------------------------------------------------------ |--- Module      :  Examples.MultiParam.Lambda--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Tagless (monadic) interpretation of extended lambda calculus--------------------------------------------------------------------------------------module Examples.MultiParam.Lambda where--import Data.Comp.MultiParam-import Data.Comp.MultiParam.Show ()-import Data.Comp.MultiParam.Equality ()-import Data.Comp.MultiParam.Derive-import Control.Monad (liftM2)-import Control.Monad.Error (MonadError, throwError)--data Lam :: (* -> *) -> (* -> *) -> * -> * where-  Lam :: (a i -> b j) -> Lam a b (i -> j)-data App :: (* -> *) -> (* -> *) -> * -> * where-  App :: b (i -> j) -> b i -> App a b j-data Const :: (* -> *) -> (* -> *) -> * -> * where-  Const :: Int -> Const a b Int-data Plus :: (* -> *) -> (* -> *) -> * -> * where-  Plus :: b Int -> b Int -> Plus a b Int-data Err :: (* -> *) -> (* -> *) -> * -> * where-  Err :: Err a b i-type Sig = Lam :+: App :+: Const :+: Plus :+: Err--$(derive [smartConstructors, makeHDifunctor, makeShowHD, makeEqHD]-         [''Lam, ''App, ''Const, ''Plus, ''Err])---- * Tagless interpretation-class Eval f where-  evalAlg :: f I I i -> i -- I . evalAlg :: Alg f I is the actual algebra--$(derive [liftSum] [''Eval])--eval :: (HDifunctor f, Eval f) => Term f i -> i-eval = unI . cata (I . evalAlg)--instance Eval Lam where-  evalAlg (Lam f) = unI . f . I--instance Eval App where-  evalAlg (App (I f) (I x)) = f x--instance Eval Const where-  evalAlg (Const n) = n--instance Eval Plus where-  evalAlg (Plus (I x) (I y)) = x + y--instance Eval Err where-  evalAlg Err = error "error"---- * Tagless monadic interpretation-type family Sem (m :: * -> *) i-type instance Sem m (i -> j) = Sem m i -> m (Sem m j)-type instance Sem m Int = Int--newtype M m i = M {unM :: m (Sem m i)}--class Monad m => EvalM m f where-  evalMAlg :: f (M m) (M m) i -> m (Sem m i) -- M . evalMAlg :: Alg f (M m)--$(derive [liftSum] [''EvalM])--evalM :: (Monad m, HDifunctor f, EvalM m f) => Term f i -> m (Sem m i)-evalM = unM . cata (M . evalMAlg)--instance Monad m => EvalM m Lam where-  evalMAlg (Lam f) = return $ unM . f . M . return--instance Monad m => EvalM m App where-  evalMAlg (App (M mf) (M mx)) = do f <- mf; f =<< mx-  -instance Monad m => EvalM m Const where-  evalMAlg (Const n) = return n--instance Monad m => EvalM m Plus where-  evalMAlg (Plus (M mx) (M my)) = liftM2 (+) mx my--instance MonadError String m => EvalM m Err where-  evalMAlg Err = throwError "error" -- 'throwError' rather than 'error'--e :: Term Sig Int-e = Term ((iLam $ \x -> (iLam (\y -> y `iPlus` x) `iApp` iConst 3)) `iApp` iConst 2)--v :: Either String Int-v = evalM e--e' :: Term Sig (Int -> Int)-e' = Term iErr --(iLam id)--v' :: Either String (Int -> Either String Int)-v' = evalM e'
− examples/Examples/Param/Graph.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, TemplateHaskell,-  FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Examples.Param.Graph--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Graph representation. The example is taken from (Fegaras and Sheard,--- Revisiting Catamorphisms over Datatypes with Embedded Functions, '96).--------------------------------------------------------------------------------------module Examples.Param.Graph where--import Data.Comp.Param-import Data.Comp.Param.Derive-import Data.Comp.Param.Show ()-import Data.Comp.Param.Equality ()--data N p a b = N p [b] -- Node-data R a b = R (a -> b) -- Recursion-data S a b = S (a -> b) b -- Sharing--$(derive [makeDifunctor, makeShowD, makeEqD, makeOrdD, smartConstructors]-         [''N, ''R, ''S])-$(derive [makeDitraversable] [''N])--type Graph p = Term (N p :+: R :+: S)--class FlatG f p where-  flatGAlg :: Alg f [p]--$(derive [liftSum] [''FlatG])--flatG :: (Difunctor f, FlatG f p) => Term f -> [p]-flatG = cata flatGAlg--instance FlatG (N p) p where-  flatGAlg (N p ps) = p : concat ps--instance FlatG R p where-  flatGAlg (R f) = f []--instance FlatG S p where-  flatGAlg (S f g) = f g--class SumG f where-  sumGAlg :: Alg f Int--$(derive [liftSum] [''SumG])--sumG :: (Difunctor f, SumG f) => Term f -> Int-sumG = cata sumGAlg--instance SumG (N Int) where-  sumGAlg (N p ps) = p + sum ps--instance SumG R where-  sumGAlg (R f) = f 0--instance SumG S where-  sumGAlg (S f g) = f g--g :: Graph Int-g = Term $ iR (\x -> iS (\z -> iN (0 :: Int) [z,iR $ \y -> iN (1 :: Int) [y,z]])-                        (iN (2 :: Int) [x]))--f :: [Int]-f = flatG g--n :: Int-n = sumG g
− examples/Examples/Param/Lambda.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,-  FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances, Rank2Types, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Examples.Param.Lambda--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Lambda calculus examples------ We define a pretty printer, a desugaring transformation, constant folding,--- and call-by-value interpreter for an extended variant of the simply typed--- lambda calculus.--------------------------------------------------------------------------------------module Examples.Param.Lambda where--import Data.Comp.Param-import Data.Comp.Param.Show ()-import Data.Comp.Param.Equality ()-import Data.Comp.Param.Ordering ()-import Data.Comp.Param.Derive-import Data.Comp.Param.Desugar--data Lam a b   = Lam (a -> b)-data App a b   = App b b-data Const a b = Const Int-data Plus a b  = Plus b b-data Let a b   = Let b (a -> b)-data Err a b   = Err--type Sig       = Lam :+: App :+: Const :+: Plus :+: Let :+: Err-type Sig'      = Lam :+: App :+: Const :+: Plus :+: Err--$(derive [smartConstructors, makeDifunctor, makeShowD, makeEqD, makeOrdD]-         [''Lam, ''App, ''Const, ''Plus, ''Let, ''Err])---- * Pretty printing-data Stream a = Cons a (Stream a)--class Pretty f where-  prettyAlg :: Alg f (Stream String -> String)--$(derive [liftSum] [''Pretty])--pretty :: (Difunctor f, Pretty f) => Term f -> String-pretty t = cata prettyAlg t (nominals 1)-    where nominals n = Cons ('x' : show n) (nominals (n + 1))--instance Pretty Lam where-  prettyAlg (Lam f) (Cons x xs) = "(\\" ++ x ++ ". " ++ f (const x) xs ++ ")"--instance Pretty App where-  prettyAlg (App e1 e2) xs = "(" ++ e1 xs ++ " " ++ e2 xs ++ ")"--instance Pretty Const where-  prettyAlg (Const n) _ = show n--instance Pretty Plus where-  prettyAlg (Plus e1 e2) xs = "(" ++ e1 xs ++ " + " ++ e2 xs ++ ")"--instance Pretty Err where-  prettyAlg Err _ = "error"--instance Pretty Let where-  prettyAlg (Let e1 e2) (Cons x xs) = "let " ++ x ++ " = " ++ e1 xs ++ " in " ++ e2 (const x) xs---- * Desugaring-instance (Difunctor f, App :<: f, Lam :<: f) => Desugar Let f where-  desugHom' (Let e1 e2) = inject (Lam e2) `iApp` e1---- * Constant folding-class Constf f g where-  constfAlg :: forall a. Alg f (Trm g a)--$(derive [liftSum] [''Constf])--constf :: (Difunctor f, Constf f g) => Term f -> Term g-constf t = Term (cata constfAlg t)--instance (Difunctor f, f :<: g) => Constf f g where-  constfAlg = inject . dimap Var id -- default instance--instance (Plus :<: f, Const :<: f) => Constf Plus f where-  constfAlg (Plus e1 e2) = case (project e1, project e2) of-                             (Just (Const n),Just (Const m)) -> iConst (n + m)-                             _                               -> e1 `iPlus` e2---- * Call-by-value evaluation-data Sem m = Fun (Sem m -> m (Sem m)) | Int Int--class Monad m => Eval f m where-  evalAlg :: Alg f (m (Sem m))--$(derive [liftSum] [''Eval])--eval :: (Difunctor f, Eval f m) => Term f -> m (Sem m)-eval = cata evalAlg--instance Monad m => Eval Lam m where-  evalAlg (Lam f) = return (Fun (f . return))--instance Monad m => Eval App m where-  evalAlg (App mx my) = do x <- mx-                           case x of Fun f -> f =<< my; _ -> fail "stuck"--instance Monad m => Eval Const m where-  evalAlg (Const n) = return (Int n)--instance Monad m => Eval Plus m where-  evalAlg (Plus mx my) = do x <- mx-                            y <- my-                            case (x,y) of (Int n,Int m) -> return (Int (n + m))-                                          _             -> fail "stuck"--instance Monad m => Eval Err m where-  evalAlg Err = fail "error"--e :: Term Sig-e = Term (iLet (iConst 2) (\x -> (iLam (\y -> y `iPlus` x) `iApp` iConst 3)))--e' :: Term Sig'-e' = desugar e--evalEx :: Maybe (Sem Maybe)-evalEx = eval e'
− examples/Examples/Param/Names.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,-  FlexibleInstances, FlexibleContexts, UndecidableInstances,-  OverlappingInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Examples.Param.Names--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ From names to parametric higher-order abstract syntax and back------ The example illustrates how to convert a parse tree with explicit names into--- an AST that uses parametric higher-order abstract syntax, and back again. The--- example shows how we can easily convert object language binders to Haskell--- binders, without having to worry about capture avoidance.--------------------------------------------------------------------------------------module Examples.Param.Names where--import Data.Comp.Param hiding (Var)-import qualified Data.Comp.Param as P-import Data.Comp.Param.Derive-import Data.Comp.Param.Ditraversable-import Data.Comp.Param.Show ()-import Data.Maybe-import qualified Data.Map as Map-import Control.Monad.Reader--data Lam a b  = Lam (a -> b)-data App a b  = App b b-data Lit a b  = Lit Int-data Plus a b = Plus b b-type Name     = String                 -- The type of names-data NLam a b = NLam Name b-data NVar a b = NVar Name-type SigB     = App :+: Lit :+: Plus-type SigN     = NLam :+: NVar :+: SigB -- The name signature-type SigP     = Lam :+: SigB           -- The PHOAS signature--$(derive [makeDifunctor, makeShowD, makeEqD, smartConstructors]-         [''Lam, ''App, ''Lit, ''Plus, ''NLam, ''NVar])-$(derive [makeDitraversable]-         [''App, ''Lit, ''Plus, ''NLam, ''NVar])------------------------------------------------------------------------------------- Names to PHOAS translation-----------------------------------------------------------------------------------type M f a = Reader (Map.Map Name (Trm f a))--class N2PTrans f g where-  n2pAlg :: Alg f (M g a (Trm g a))----- We make the lifting to sums explicit in order to make the N2PTrans--- work with the default instance declaration further below.-instance (N2PTrans f1 g, N2PTrans f2 g) => N2PTrans (f1 :+: f2) g where-    n2pAlg = caseD n2pAlg n2pAlg--n2p :: (Difunctor f, N2PTrans f g) => Term f -> Term g-n2p t = Term $ runReader (cata n2pAlg t) Map.empty--instance (Lam :<: g) => N2PTrans NLam g where-  n2pAlg (NLam x b) = do vars <- ask-                         return $ iLam $ \y -> runReader b (Map.insert x y vars)--instance (Ditraversable f, f :<: g) => N2PTrans f g where-  n2pAlg = liftM inject . disequence . dimap (return . P.Var) id -- default--instance N2PTrans NVar g where-  n2pAlg (NVar x) = liftM fromJust (asks (Map.lookup x))--en :: Term SigN-en = Term $ iNLam "x1" $ iNLam "x2" (iNLam "x3" $ iNVar "x2") `iApp` iNVar "x1"--ep :: Term SigP-ep = n2p en------------------------------------------------------------------------------------- PHOAS to names translation-----------------------------------------------------------------------------------type M' = Reader [Name]--class P2NTrans f g where-  p2nAlg :: Alg f (M' (Trm g a))----- We make the lifting to sums explicit in order to make the P2NTrans--- work with the default instance declaration further below.-instance (P2NTrans f1 g, P2NTrans f2 g) => P2NTrans (f1 :+: f2) g where-    p2nAlg = caseD p2nAlg p2nAlg---p2n :: (Difunctor f, P2NTrans f g) => Term f -> Term g-p2n t = Term $ runReader (cata p2nAlg t) ['x' : show n | n <- [1..]]--instance (Ditraversable f, f :<: g) => P2NTrans f g where-  p2nAlg = liftM inject . disequence . dimap (return . P.Var) id -- default--instance (NLam :<: g, NVar :<: g) => P2NTrans Lam g where-  p2nAlg (Lam f) = do n:names <- ask-                      return $ iNLam n (runReader (f (return $ iNVar n)) names)--ep' :: Term SigP-ep' = Term $ iLam $ \a -> iLam (\b -> (iLam $ \_ -> b)) `iApp` a--en' :: Term SigN-en' = p2n ep'
+ examples/Examples/Thunk.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, DeriveFunctor,+  FlexibleInstances, FlexibleContexts, UndecidableInstances, ConstraintKinds,+  CPP #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Examples.Thunk+-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved+-- License     :  BSD3+-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This example illustrates how the ''Data.Comp.Thunk'' package can be+-- used to implement a non-strict language (or a partially non-strict+-- language).+--+--------------------------------------------------------------------------------++module Examples.Thunk where++import Data.Comp+import Data.Comp.Thunk+import Data.Comp.Derive+import Data.Comp.Show()+import Examples.Common hiding (Value(..), Sig, iConst, iPair)++-- Control.Monad.Fail import is redundant since GHC 8.8.1+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif++-- Signature for values, strict pairs+data Value a = Const Int | Pair !a !a deriving Functor++-- Signature for the simple expression language+type Sig = Op :+: Value++-- Derive boilerplate code using Template Haskell+$(derive [makeTraversable, makeFoldable,+          makeEqF, makeShowF, smartConstructors, makeHaskellStrict]+         [''Value])++-- Monadic term evaluation algebra+class EvalT f m v where+  evalAlgT :: MonadFail m => AlgT m f v++$(derive [liftSum] [''EvalT])++-- Lift the monadic evaluation algebra to a monadic catamorphism+evalT :: (Traversable v, Functor f, EvalT f m v, MonadFail m) => Term f -> m (Term v)+evalT = nf . cata evalAlgT++instance (Value :<: m :+: v) => EvalT Value m v where+-- make pairs strict in both components+--  evalAlgT x@Pair{} = strict x+-- or explicitly:+--  evalAlgT (Pair x y) = thunk $ liftM2 iPair (dethunk' x) (dethunk' )y+--  evalAlgT x = inject x++-- or only partially strict+  evalAlgT = haskellStrict'++instance (Value :<: m :+: v, Value :<: v) => EvalT Op m v where+  evalAlgT (Add x y) = thunk $ do+                         Const n1 <- whnfPr x+                         Const n2 <- whnfPr y+                         return $ iConst $ n1 + n2+  evalAlgT (Mult x y) = thunk $ do+                          Const n1 <- whnfPr x+                          Const n2 <- whnfPr y+                          return $ iConst $ n1 * n2+  evalAlgT (Fst v)    = thunk $ do +                          Pair x _  <- whnfPr v+                          return x+  evalAlgT (Snd v)    = thunk $ do +                          Pair _ y <- whnfPr v+                          return y+++instance MonadFail (Either String) where+    fail = Left++evalTEx :: Either String (Term Value)+evalTEx = evalT (iSnd (iFst (iConst 5) `iPair` iConst 4) :: Term Sig)
src/Data/Comp.hs view
@@ -18,10 +18,10 @@      module X     ) where -import Data.Comp.Term as X import Data.Comp.Algebra as X-import Data.Comp.Sum as X import Data.Comp.Annotation as X import Data.Comp.Equality as X-import Data.Comp.Ordering as X import Data.Comp.Generic as X+import Data.Comp.Ordering as X+import Data.Comp.Sum as X+import Data.Comp.Term as X
src/Data/Comp/Algebra.hs view
@@ -1,5 +1,10 @@-{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables, TypeOperators,-  FlexibleContexts, CPP #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Algebra@@ -21,7 +26,7 @@       cata,       cata',       appCxt,-      +       -- * Monadic Algebras & Catamorphisms       AlgM,       algM,@@ -104,12 +109,12 @@       futuM     ) where -import Data.Comp.Term+import Control.Monad hiding (mapM, sequence) import Data.Comp.Ops+import Data.Comp.Term import Data.Traversable-import Control.Monad hiding (sequence, mapM) -import Prelude hiding (sequence, mapM)+import Prelude hiding (mapM, sequence)   @@ -127,13 +132,13 @@           run (Term t) = f (fmap run t)  {-| Construct a catamorphism from the given algebra. -}-cata :: forall f a . (Functor f) => Alg f a -> Term f -> a +cata :: forall f a . (Functor f) => Alg f a -> Term f -> a {-# NOINLINE [1] cata #-} -- cata f = free f undefined -- the above definition is safe since terms do not contain holes -- -- a direct implementation:-cata f = run +cata f = run     where run :: Term f -> a           run  = f . fmap run . unTerm @@ -157,7 +162,7 @@ {-| This type represents a monadic algebra. It is similar to 'Alg' but the return type is monadic.  -} -type AlgM m f a = f a -> m a +type AlgM m f a = f a -> m a  {-| Convert a monadic algebra into an ordinary algebra with a monadic   carrier. -}@@ -175,7 +180,7 @@           run (Term t) = algm =<< mapM run t  {-| Construct a monadic catamorphism from the given monadic algebra. -}-cataM :: forall f m a. (Traversable f, Monad m) => AlgM m f a -> Term f -> m a +cataM :: forall f m a. (Traversable f, Monad m) => AlgM m f a -> Term f -> m a {-# NOINLINE [1] cataM #-} -- cataM = cata . algM cataM algm = run@@ -351,7 +356,7 @@ initial term algebra to the given term algebra. -} homMD :: forall f g m . (Traversable f, Functor g, Monad m)           => HomMD m f g -> CxtFunM m f g-homMD f = run +homMD f = run     where run :: Cxt h f a -> m (Cxt h g a)           run (Hole x) = return (Hole x)           run (Term t) = liftM appCxt (f (fmap run t))@@ -379,7 +384,7 @@ {-| This function applies a signature function to the given context. -} appSigFunMD :: forall f g m . (Traversable f, Functor g, Monad m)               => SigFunMD m f g -> CxtFunM m f g-appSigFunMD f = run +appSigFunMD f = run     where run :: Cxt h f a -> m (Cxt h g a)           run (Hole x) = return (Hole x)           run (Term t) = liftM Term (f (fmap run t))@@ -394,11 +399,6 @@                 => HomM m g h -> HomM m f g -> HomM m f h compHomM' f g = appHomM' f <=< g -{-| Compose two monadic term homomorphisms. -}-compHomM_ :: (Functor h, Functor g, Monad m)-                => Hom g h -> HomM m f g -> HomM m f h-compHomM_ f g = liftM (appHom f) . g- {-| Compose a monadic algebra with a monadic term homomorphism to get a new   monadic algebra. -} compAlgM :: (Traversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a@@ -449,12 +449,12 @@  -- | Shortcut fusion variant of 'ana'. ana' :: forall a f . Functor f => Coalg f a -> a -> Term f-ana' f t = build $ run t+ana' f t = build (run t)     where run :: forall b . a -> Alg f b -> b           run t con = run' t where               run' :: a ->  b               run' t = con $ fmap run' (f t)-+{-# INLINE [2] ana' #-} build :: (forall a. Alg f a -> a) -> Term f {-# INLINE [1] build #-} build g = g Term@@ -466,7 +466,7 @@ {-| Construct a monadic anamorphism from the given monadic coalgebra. -} anaM :: forall a m f. (Traversable f, Monad m)           => CoalgM m f a -> a -> m (Term f)-anaM f = run +anaM f = run     where run :: a -> m (Term f)           run t = liftM Term $ f t >>= mapM run @@ -488,7 +488,7 @@ type RAlgM m f a = f (Term f, a) -> m a  {-| Construct a monadic paramorphism from the given monadic r-algebra. -}-paraM :: (Traversable f, Monad m) => +paraM :: (Traversable f, Monad m) =>          RAlgM m f a -> Term f -> m a paraM f = liftM snd . cataM run     where run t = do@@ -504,7 +504,7 @@  {-| Construct an apomorphism from the given r-coalgebra. -} apo :: (Functor f) => RCoalg f a -> a -> Term f-apo f = run +apo f = run     where run = Term . fmap run' . f           run' (Left t) = t           run' (Right a) = run a@@ -521,7 +521,7 @@ {-| Construct a monadic apomorphism from the given monadic r-coalgebra. -} apoM :: (Traversable f, Monad m) =>         RCoalgM m f a -> a -> m (Term f)-apoM f = run +apoM f = run     where run a = do             t <- f a             t' <- mapM run' t@@ -607,6 +607,7 @@   appAlgHom :: forall f g d . (Functor g) => Alg g d -> Hom f g -> Term f -> d+{-# NOINLINE [1] appAlgHom #-} appAlgHom alg hom = run where     run :: Term f -> d     run (Term t) = run' $ hom t@@ -632,6 +633,7 @@ -- requirements on the source signature @f@. appAlgHomM :: forall m f g a. (Traversable g, Monad m)                => AlgM m g a -> HomM m f g -> Term f -> m a+{-# NOINLINE [1] appAlgHomM #-} appAlgHomM alg hom = run     where run :: Term f -> m a           run (Term t) = hom t >>= mapM run >>= run'@@ -712,7 +714,7 @@    "appHom/appHom'" forall (a :: Hom g h) (h :: Hom f g) x.     appHom a (appHom' h x) = appHom' (compHom a h) x;-    +   "appSigFun/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.     appSigFun f (appSigFun g x) = appSigFun (compSigFun f g) x; @@ -736,7 +738,7 @@    "appHom'/appSigFun" forall (f :: Hom g h) (g :: SigFun f g) x.     appHom' f (appSigFun g x) = appHom (compHomSigFun f g) x;-    +   "appSigFun/appHom" forall (f :: SigFun g h) (g :: Hom f g) x.     appSigFun f (appHom g x) = appSigFunHom f g x; @@ -748,7 +750,7 @@    "appSigFun'/appHom" forall (f :: SigFun g h) (g :: Hom f g) x.     appSigFun' f (appHom g x) = appHom (compSigFunHom f g) x;-    +   "appSigFunHom/appSigFun" forall (f :: SigFun f3 f4) (g :: Hom f2 f3)                                       (h :: SigFun f1 f2) x.     appSigFunHom f g (appSigFun h x)@@ -788,10 +790,9 @@   "appSigFunHom/appSigFunHom" forall (f1 :: SigFun f4 f5) (f2 :: Hom f3 f4)                                              (f3 :: SigFun f2 f3) (f4 :: Hom f1 f2) x.     appSigFunHom f1 f2 (appSigFunHom f3 f4 x)-      = appSigFunHom f1 (compHom (compHomSigFun f2 f3) f4) x;- #-}+      = appSigFunHom f1 (compHom (compHomSigFun f2 f3) f4) x; #-} -{-# RULES +{-# RULES   "cataM/appHomM" forall (a :: AlgM Maybe g d) (h :: HomM Maybe f g) x.      appHomM h x >>= cataM a =  appAlgHomM a h x; @@ -917,14 +918,9 @@    "appSigFunM'/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.      appSigFunM' a (appSigFun' h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;---  "appHom/appHomM" forall (a :: Hom g h) (h :: HomM m f g) x.-     appHomM h x >>= (return . appHom a) = appHomM (compHomM_ a h) x;- #-}+#-}  {-# RULES   "cata/build"  forall alg (g :: forall a . Alg f a -> a) .-                cata alg (build g) = g alg- #-}+                cata alg (build g) = g alg  #-} #endif
src/Data/Comp/Annotation.hs view
@@ -1,9 +1,16 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,-  UndecidableInstances, Rank2Types, GADTs, ScopedTypeVariables, FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Annotation--- Copyright   :  (c) 2010-2011 Patrick Bahr+-- Copyright   :  (c) 2010-2013 Patrick Bahr -- License     :  BSD3 -- Maintainer  :  Patrick Bahr <paba@diku.dk> -- Stability   :  experimental@@ -23,21 +30,17 @@      liftA',      stripA,      propAnn,-     propAnnQ,-     propAnnUp,-     propAnnDown,      propAnnM,      ann,      project'     ) where -import Data.Comp.Term-import Data.Comp.Sum-import Data.Comp.Ops-import Data.Comp.Algebra-import Data.Comp.Automata import Control.Monad+import Data.Comp.Algebra+import Data.Comp.Ops+import Data.Comp.Term + {-| Transform a function with a domain constructed from a functor to a function  with a domain constructed with the same functor, but with an additional  annotation. -}@@ -51,47 +54,22 @@        => (s' a -> Cxt h s' a) -> s a -> Cxt h s a liftA' f v = let (v',p) = projectA v              in ann p (f v')-    + {-| Strip the annotations from a term over a functor with annotations. -} stripA :: (RemA g f, Functor g) => CxtFun g f stripA = appSigFun remA  {-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism  over the same signatures, but extended with annotations. -}-propAnn :: (DistAnn f p f', DistAnn g p g', Functor g) +propAnn :: (DistAnn f p f', DistAnn g p g', Functor g)         => Hom f g -> Hom f' g' propAnn hom f' = ann p (hom f)     where (f,p) = projectA f'  --- | Lift a stateful term homomorphism over signatures @f@ and @g@ to--- a stateful term homomorphism over the same signatures, but extended with--- annotations.-propAnnQ :: (DistAnn f p f', DistAnn g p g', Functor g) -        => QHom f q g -> QHom f' q g'-propAnnQ hom f' = ann p (hom f)-    where (f,p) = projectA f'---- | Lift a bottom-up tree transducer over signatures @f@ and @g@ to a--- bottom-up tree transducer over the same signatures, but extended--- with annotations.-propAnnUp :: (DistAnn f p f', DistAnn g p g', Functor g) -        => UpTrans f q g -> UpTrans f' q g'-propAnnUp trans f' = (q, ann p t)-    where (f,p) = projectA f'-          (q,t) = trans f---- | Lift a top-down tree transducer over signatures @f@ and @g@ to a--- top-down tree transducer over the same signatures, but extended--- with annotations.-propAnnDown :: (DistAnn f p f', DistAnn g p g', Functor g) -        => DownTrans f q g -> DownTrans f' q g'-propAnnDown trans (q, f') = ann p (trans (q, f))-    where (f,p) = projectA f'- {-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic   term homomorphism over the same signatures, but extended with annotations. -}-propAnnM :: (DistAnn f p f', DistAnn g p g', Functor g, Monad m) +propAnnM :: (DistAnn f p f', DistAnn g p g', Functor g, Monad m)          => HomM m f g -> HomM m f' g' propAnnM hom f' = liftM (ann p) (hom f)     where (f,p) = projectA f'@@ -100,9 +78,9 @@ ann :: (DistAnn f p g, Functor f) => p -> CxtFun f g ann c = appSigFun (injectA c) + {-| This function is similar to 'project' but applies to signatures with an annotation which is then ignored. -}--- bug in type checker? below is the inferred type, however, the type checker--- rejects it.-project' :: forall f g f1 a h . (RemA f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))-project' v = liftM remA (project v :: Maybe (f (Cxt h f1 a)))+project' :: (RemA f f', s :<: f') => Cxt h f a -> Maybe (s (Cxt h f a))+project' (Term x) = proj $ remA x+project' _ = Nothing
src/Data/Comp/Arbitrary.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE TypeOperators, TypeSynonymInstances, GADTs, TemplateHaskell, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Arbitrary@@ -17,13 +21,11 @@     ( ArbitraryF(..)     )where -import Test.QuickCheck-import Data.Comp.Term-import Data.Comp.Sum-import Data.Comp.Ops-import Data.Comp.Derive.Utils import Data.Comp.Derive-import Control.Applicative+import Data.Comp.Derive.Utils+import Data.Comp.Ops+import Data.Comp.Term+import Test.QuickCheck  {-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary' for the corresponding term type. -}@@ -36,10 +38,10 @@     arbitraryF' = map addP arbitraryF'         where addP (i,gen) =  (i,(:&:) <$> gen <*> arbitrary)     arbitraryF = (:&:) <$> arbitraryF <*> arbitrary-    shrinkF (v :&: p) = tail [v' :&: p'| v' <- v: shrinkF v, p' <- p : shrink p ]+    shrinkF (v :&: p) = drop 1 [v' :&: p'| v' <- v: shrinkF v, p' <- p : shrink p ]  {-|-  This lifts instances of 'ArbitraryF' to instances of 'ArbitraryF' for +  This lifts instances of 'ArbitraryF' to instances of 'ArbitraryF' for   the corresponding context functor. -} instance (ArbitraryF f) => ArbitraryF (Context f) where
− src/Data/Comp/Automata.hs 
@@ -1,483 +0,0 @@-{-# LANGUAGE Rank2Types, FlexibleContexts, ImplicitParams, GADTs, TypeOperators #-}------------------------------------------------------------------------------------- |--- Module      :  Data.Comp.Automata--- Copyright   :  (c) 2010-2012 Patrick Bahr--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines stateful term homomorphisms. This (slightly--- oxymoronic) notion extends per se stateless term homomorphisms with--- a state that is maintained separately by a bottom-up or top-down--- state transformation. Additionally, this module also provides--- combinators to run state transformations themselves.--- --- Like regular term homomorphisms also stateful homomorphisms (as--- well as transducers) can be lifted to annotated signatures--- (cf. "Data.Comp.Annotation").------ The recursion schemes provided in this module are derived from tree--- automata. They allow for a higher degree of modularity and make it--- possible to apply fusion. The implementation is based on the paper--- /Modular Tree Automata/ (Mathematics of Program Construction,--- 263-299, 2012, <http://dx.doi.org/10.1007/978-3-642-31113-0_14>).--------------------------------------------------------------------------------------module Data.Comp.Automata-    (-    -- * Stateful Term Homomorphisms-      QHom-    , below-    , above-    , pureHom-    -- ** Bottom-Up State Propagation-    , upTrans-    , runUpHom-    , runUpHomSt-    -- ** Top-Down State Propagation-    , downTrans-    , runDownHom-    -- ** Bidirectional State Propagation-    , runQHom-    -- * Deterministic Bottom-Up Tree Transducers-    , UpTrans-    , runUpTrans-    , compUpTrans-    , compUpTransHom-    , compHomUpTrans-    , compUpTransSig-    , compSigUpTrans-    , compAlgUpTrans-    -- * Deterministic Bottom-Up Tree State Transformations-    -- ** Monolithic State-    , UpState-    , tagUpState-    , runUpState-    , prodUpState-    -- ** Modular State-    , DUpState-    , dUpState-    , upState-    , runDUpState-    , prodDUpState-    , (<*>)-    -- * Deterministic Top-Down Tree Transducers-    , DownTrans-    , runDownTrans-    , compDownTrans-    , compDownTransSig-    , compSigDownTrans-    , compDownTransHom-    , compHomDownTrans-    -- * Deterministic Top-Down Tree State Transformations-    -- ** Monolithic State-    , DownState-    , tagDownState-    , prodDownState-    -- ** Modular State-    , DDownState-    , dDownState-    , downState-    , prodDDownState-    , (>*<)-    -- * Bidirectional Tree State Transformations-    , runDState-    -- * Operators for Finite Mappings-    , (&)-    , (|->)-    , o-    -- * Product State Spaces-    , module Data.Comp.Automata.Product-    ) where--import Data.Comp.Number-import Data.Comp.Automata.Product-import Data.Comp.Term-import Data.Comp.Algebra-import Data.Map (Map)-import qualified Data.Map as Map------ The following are operators to specify finite mappings.---infix 1 |->-infixr 0 &---- | left-biased union of two mappings.--(&) :: Ord k => Map k v -> Map k v -> Map k v-(&) = Map.union---- | This operator constructs a singleton mapping.--(|->) :: k -> a -> Map k a-(|->) = Map.singleton---- | This is the empty mapping.--o :: Map k a-o = Map.empty---- | This function provides access to components of the states from--- "below".--below :: (?below :: a -> q, p :< q) => a -> p-below = pr . ?below---- | This function provides access to components of the state from--- "above"--above :: (?above :: q, p :< q) => p-above = pr ?above---- | Turns the explicit parameters @?above@ and @?below@ into explicit--- ones.--explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b-explicit x ab be = x where ?above = ab; ?below = be----- | This type represents stateful term homomorphisms. Stateful term--- homomorphisms have access to a state that is provided (separately)--- by a bottom-up or top-down state transformation function (or both).-                           -type QHom f q g = forall a . (?below :: a -> q, ?above :: q) => f a -> Context g a----- | This function turns a stateful homomorphism with a fully--- polymorphic state type into a (stateless) homomorphism.-pureHom :: (forall q . QHom f q g) -> Hom f g-pureHom phom t = let ?above = undefined -                     ?below = const undefined-                 in phom t---- | This type represents transition functions of deterministic--- bottom-up tree transducers (DUTTs).--type UpTrans f q g = forall a. f (q,a) -> (q, Context g a)---- | This function transforms a DUTT transition function into an--- algebra.--upAlg :: (Functor g)  => UpTrans f q g -> Alg f (q, Term g)-upAlg trans = fmap appCxt . trans ---- | This function runs the given DUTT on the given term.--runUpTrans :: (Functor f, Functor g) => UpTrans f q g -> Term f -> Term g-runUpTrans trans = snd . runUpTransSt trans---- | This function is a variant of 'runUpTrans' that additionally--- returns the final state of the run.--runUpTransSt :: (Functor f, Functor g) => UpTrans f q g -> Term f -> (q, Term g)-runUpTransSt = cata . upAlg---- | This function generalises 'runUpTrans' to contexts. Therefore,--- additionally, a transition function for the holes is needed.--runUpTrans' :: (Functor f, Functor g) => UpTrans f q g -> Context f (q,a) -> (q, Context g a)-runUpTrans' trans = run where-    run (Hole (q,a)) = (q, Hole a)-    run (Term t) = fmap appCxt $ trans $ fmap run t---- | This function composes two DUTTs. (see TATA, Theorem 6.4.5)-    -compUpTrans :: (Functor f, Functor g, Functor h)-               => UpTrans g p h -> UpTrans f q g -> UpTrans f (q,p) h-compUpTrans t2 t1 x = ((q1,q2), c2) where-    (q1, c1) = t1 $ fmap (\((q1,q2),a) -> (q1,(q2,a))) x-    (q2, c2) = runUpTrans' t2 c1----- | This function composes a DUTT with an algebra.-    -compAlgUpTrans :: (Functor g)-               => Alg g a -> UpTrans f q g -> Alg f (q,a)-compAlgUpTrans alg trans = fmap (cata' alg) . trans----- | This combinator composes a DUTT followed by a signature function.--compSigUpTrans :: (Functor g) => SigFun g h -> UpTrans f q g -> UpTrans f q h-compSigUpTrans sig trans x = (q, appSigFun sig x') where-    (q, x') = trans x---- | This combinator composes a signature function followed by a DUTT.-    -compUpTransSig :: UpTrans g q h -> SigFun f g -> UpTrans f q h-compUpTransSig trans sig = trans . sig---- | This combinator composes a DUTT followed by a homomorphism.--compHomUpTrans :: (Functor g, Functor h) => Hom g h -> UpTrans f q g -> UpTrans f q h-compHomUpTrans hom trans x = (q, appHom hom x') where-    (q, x') = trans x---- | This combinator composes a homomorphism followed by a DUTT.-    -compUpTransHom :: (Functor g, Functor h) => UpTrans g q h -> Hom f g -> UpTrans f q h-compUpTransHom trans hom x  = runUpTrans' trans . hom $ x---- | This type represents transition functions of deterministic--- bottom-up tree acceptors (DUTAs).--type UpState f q = Alg f q---- | Changes the state space of the DUTA using the given isomorphism.--tagUpState :: (Functor f) => (q -> p) -> (p -> q) -> UpState f q -> UpState f p-tagUpState i o s = i . s . fmap o---- | This combinator runs the given DUTA on a term returning the final--- state of the run.--runUpState :: (Functor f) => UpState f q -> Term f -> q-runUpState = cata---- | This function combines the product DUTA of the two given DUTAs.--prodUpState :: Functor f => UpState f p -> UpState f q -> UpState f (p,q)-prodUpState sp sq t = (p,q) where-    p = sp $ fmap fst t-    q = sq $ fmap snd t----- | This function constructs a DUTT from a given stateful term--- homomorphism with the state propagated by the given DUTA.-    -upTrans :: (Functor f, Functor g) => UpState f q -> QHom f q g -> UpTrans f q g-upTrans st f t = (q, c)-    where q = st $ fmap fst t-          c = fmap snd $ explicit f q fst t---- | This function applies a given stateful term homomorphism with--- a state space propagated by the given DUTA to a term.-          -runUpHom :: (Functor f, Functor g) => UpState f q -> QHom f q g -> Term f -> Term g-runUpHom st hom = snd . runUpHomSt st hom---- | This is a variant of 'runUpHom' that also returns the final state--- of the run.--runUpHomSt :: (Functor f, Functor g) => UpState f q -> QHom f q g -> Term f -> (q,Term g)-runUpHomSt alg h = runUpTransSt (upTrans alg h)----- | This type represents transition functions of generalised--- deterministic bottom-up tree acceptors (GDUTAs) which have access--- to an extended state space.--type DUpState f p q = forall a . (?below :: a -> p, ?above :: p, q :< p) => f a -> q---- | This combinator turns an arbitrary DUTA into a GDUTA.--dUpState :: Functor f => UpState f q -> DUpState f p q-dUpState f = f . fmap below---- | This combinator turns a GDUTA with the smallest possible state--- space into a DUTA.--upState :: DUpState f q q -> UpState f q-upState f s = res where res = explicit f res id s---- | This combinator runs a GDUTA on a term.-                        -runDUpState :: Functor f => DUpState f q q -> Term f -> q-runDUpState = runUpState . upState---- | This combinator constructs the product of two GDUTA.--prodDUpState :: (p :< c, q :< c)-             => DUpState f c p -> DUpState f c q -> DUpState f c (p,q)-prodDUpState sp sq t = (sp t, sq t)--(<*>) :: (p :< c, q :< c)-             => DUpState f c p -> DUpState f c q -> DUpState f c (p,q)-(<*>) = prodDUpState------ | This type represents transition functions of deterministic--- top-down tree transducers (DDTTs).--type DownTrans f q g = forall a. (q, f a) -> Context g (q,a)---- | Thsis function runs the given DDTT on the given tree.--runDownTrans :: (Functor f, Functor g) => DownTrans f q g -> q -> Cxt h f a -> Cxt h g a-runDownTrans tr q t = run (q,t) where-    run (q,Term t) = appCxt $ fmap run $  tr (q, t)-    run (_,Hole a)      = Hole a---- | This function runs the given DDTT on the given tree.-    -runDownTrans' :: (Functor f, Functor g) => DownTrans f q g -> q -> Cxt h f a -> Cxt h g (q,a)-runDownTrans' tr q t = run (q,t) where-    run (q,Term t) = appCxt $ fmap run $  tr (q, t)-    run (q,Hole a)      = Hole (q,a)---- | This function composes two DDTTs. (see Z. Fulop, H. Vogler--- /Syntax-Directed Semantics/, Theorem 3.39)-    -compDownTrans :: (Functor f, Functor g, Functor h)-              => DownTrans g p h -> DownTrans f q g -> DownTrans f (q,p) h-compDownTrans t2 t1 ((q,p), t) = fmap (\(p, (q, a)) -> ((q,p),a)) $ runDownTrans' t2 p (t1 (q, t))----- | This function composes a signature function after a DDTT.--compSigDownTrans :: (Functor g) => SigFun g h -> DownTrans f q g -> DownTrans f q h-compSigDownTrans sig trans = appSigFun sig . trans---- | This function composes a DDTT after a function.--compDownTransSig :: DownTrans g q h -> SigFun f g -> DownTrans f q h-compDownTransSig trans hom (q,t) = trans (q, hom t)----- | This function composes a homomorphism after a DDTT.--compHomDownTrans :: (Functor g, Functor h)-              => Hom g h -> DownTrans f q g -> DownTrans f q h-compHomDownTrans hom trans = appHom hom . trans---- | This function composes a DDTT after a homomorphism.--compDownTransHom :: (Functor g, Functor h)-              => DownTrans g q h -> Hom f g -> DownTrans f q h-compDownTransHom trans hom (q,t) = runDownTrans' trans q (hom t)----- | This type represents transition functions of deterministic--- top-down tree acceptors (DDTAs).--type DownState f q = forall a. Ord a => (q, f a) -> Map a q----- | Changes the state space of the DDTA using the given isomorphism.--tagDownState :: (q -> p) -> (p -> q) -> DownState f q -> DownState f p-tagDownState i o t (q,s) = fmap i $ t (o q,s)---- | This function constructs the product DDTA of the given two DDTAs.--prodDownState :: DownState f p -> DownState f q -> DownState f (p,q)-prodDownState sp sq ((p,q),t) = prodMap p q (sp (p, t)) (sq (q, t))----- | This type is needed to construct the product of two DDTAs.--data ProdState p q = LState p-                   | RState q-                   | BState p q--- | This function constructs the pointwise product of two maps each--- with a default value.--prodMap :: (Ord i) => p -> q -> Map i p -> Map i q -> Map i (p,q)-prodMap p q mp mq = Map.map final $ Map.unionWith combine ps qs-    where ps = Map.map LState mp-          qs = Map.map RState mq-          combine (LState p) (RState q) = BState p q-          combine (RState q) (LState p) = BState p q-          combine _ _                   = error "unexpected merging"-          final (LState p) = (p, q)-          final (RState q) = (p, q)-          final (BState p q) = (p,q)----- | Apply the given state mapping to the given functorial value by--- adding the state to the corresponding index if it is in the map and--- otherwise adding the provided default state.-          -appMap :: Traversable f => (forall i . Ord i => f i -> Map i q)-                       -> q -> f b -> f (q,b)-appMap qmap q s = fmap qfun s'-    where s' = number s-          qfun k@(Numbered (_,a)) = (Map.findWithDefault q k (qmap s') ,a)---- | This function constructs a DDTT from a given stateful term----- homomorphism with the state propagated by the given DDTA.-          -downTrans :: Traversable f => DownState f q -> QHom f q g -> DownTrans f q g-downTrans st f (q, s) = explicit f q fst (appMap (curry st q) q s)----- | This function applies a given stateful term homomorphism with a--- state space propagated by the given DDTA to a term.--runDownHom :: (Traversable f, Functor g)-            => DownState f q -> QHom f q g -> q -> Term f -> Term g-runDownHom st h = runDownTrans (downTrans st h)---- | This type represents transition functions of generalised--- deterministic top-down tree acceptors (GDDTAs) which have access---- to an extended state space.-type DDownState f p q = forall i . (Ord i, ?below :: i -> p, ?above :: p, q :< p)-                                => f i -> Map i q---- | This combinator turns an arbitrary DDTA into a GDDTA.--dDownState :: DownState f q -> DDownState f p q-dDownState f t = f (above,t)---- | This combinator turns a GDDTA with the smallest possible state--- space into a DDTA.--downState :: DDownState f q q -> DownState f q-downState f (q,s) = res-    where res = explicit f q bel s-          bel k = Map.findWithDefault q k res----- | This combinator constructs the product of two dependant top-down--- state transformations.-          -prodDDownState :: (p :< c, q :< c)-               => DDownState f c p -> DDownState f c q -> DDownState f c (p,q)-prodDDownState sp sq t = prodMap above above (sp t) (sq t)---- | This is a synonym for 'prodDDownState'.--(>*<) :: (p :< c, q :< c, Functor f)-         => DDownState f c p -> DDownState f c q -> DDownState f c (p,q)-(>*<) = prodDDownState----- | This combinator combines a bottom-up and a top-down state--- transformations. Both state transformations can depend mutually--- recursive on each other.--runDState :: Traversable f => DUpState f (u,d) u -> DDownState f (u,d) d -> d -> Term f -> u-runDState up down d (Term t) = u where-        t' = fmap bel $ number t-        bel (Numbered (i,s)) = -            let d' = Map.findWithDefault d (Numbered (i,undefined)) m-            in Numbered (i, (runDState up down d' s, d'))-        m = explicit down (u,d) unNumbered t'-        u = explicit up (u,d) unNumbered t'---- | This combinator runs a stateful term homomorphisms with a state--- space produced both on a bottom-up and a top-down state--- transformation.-        -runQHom :: (Traversable f, Functor g) =>-           DUpState f (u,d) u -> DDownState f (u,d) d -> -           QHom f (u,d) g ->-           d -> Term f -> (u, Term g)-runQHom up down trans d (Term t) = (u,t'') where-        t' = fmap bel $ number t-        bel (Numbered (i,s)) = -            let d' = Map.findWithDefault d (Numbered (i,undefined)) m-                (u', s') = runQHom up down trans d' s-            in Numbered (i, ((u', d'),s'))-        m = explicit down (u,d) (fst . unNumbered) t'-        u = explicit up (u,d) (fst . unNumbered) t'-        t'' = appCxt $ fmap (snd . unNumbered) $  explicit trans (u,d) (fst . unNumbered) t'
− src/Data/Comp/Automata/Product.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances, IncoherentInstances, TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Automata.Product--- Copyright   :  (c) 2011 Patrick Bahr--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)-----------------------------------------------------------------------------------------module Data.Comp.Automata.Product ((:<)(..)) where--import Data.Comp.Automata.Product.Derive---instance a :< a where-    pr = id--$(genAllInsts 7)--instance (c :< b) => c :< (a,b) where-    pr = pr . snd
− src/Data/Comp/Automata/Product/Derive.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances, IncoherentInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Automata.Product.Derive--- Copyright   :  (c) 2011 Patrick Bahr--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)-----------------------------------------------------------------------------------------module Data.Comp.Automata.Product.Derive where--import Language.Haskell.TH---- | An instance @a :< b@ means that @a@ is a component of @b@. @a@--- can be extracted from @b@ via the method 'pr'.-class a :< b where-    pr :: b -> a--data Dir = L | R-         deriving Show--genAllInsts :: Int -> Q [Dec]-genAllInsts n = mapM genInst dirs-    where dirs = map (L:) (genDirs n)--genDirs :: Int -> [[Dir]]-genDirs 0 = [[]]-genDirs n = [] : map (L:) dirs ++ map (R:) dirs-    where dirs = genDirs (n-1)--genInst :: [Dir] -> Q Dec-genInst dir = do -  n <- newName "a"-  ty <- genType n dir-  ex <- genEx dir-  return $ InstanceD [] (ConT (mkName ":<") `AppT` VarT n `AppT` ty) [ex]--genType :: Name -> [Dir] -> Q Type-genType n = gen-    where gen [] = varT n-          gen (L:dir) =  gen dir `pairT` (varT =<< newName "a")-          gen (R:dir) =  (varT =<< newName "a") `pairT` gen dir --genPat :: Name -> [Dir] -> PatQ-genPat n = gen where-    gen [] = varP n-    gen (L:dir) = tupP [gen dir,wildP]-    gen (R:dir) = tupP [wildP,gen dir]--genEx :: [Dir] -> DecQ-genEx dir = do-  n <- newName "x"-  p <- genPat n dir-  return $ FunD (mkName "pr") [Clause [p] (NormalB (VarE n)) []]--genPatExp :: Name -> [Dir] -> Q (Pat, Exp)-genPatExp n = gen where-    gen [] = return (WildP, VarE n)-    gen (d:dir) = do -      (p,e) <- gen dir -      x <- newName "x"-      return $ case d of-        L -> (TupP [p,VarP x] , TupE [e,VarE x])-        R -> (TupP [VarP x,p] , TupE [VarE x,e])-  ---pairT :: TypeQ -> TypeQ -> TypeQ-pairT x = appT (appT (tupleT 2) x)
src/Data/Comp/Decompose.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ConstraintKinds  #-}  -------------------------------------------------------------------------------- -- |@@ -16,7 +19,8 @@ module Data.Comp.Decompose (   Decomp (..),   DecompTerm,-  Decompose (..),+  Decompose,+  decomp,   structure,   arguments,   decompose@@ -47,20 +51,17 @@  {-| This class specifies the decomposability of a functorial value. -} -class (HasVars f v, Functor f, Foldable f) => Decompose f v where-    {-| This function decomposes a functorial value. -}--    decomp :: f a -> Decomp f v a-    decomp t = case isVar t of-                 Just v -> Var v-                 Nothing -> Fun sym args-                     where sym = fmap (const ()) t-                           args = arguments t+type Decompose f v = (HasVars f v, Functor f, Foldable f) -instance (HasVars f v, Functor f, Foldable f) => Decompose f v where+decomp :: Decompose f v => f a -> Decomp f v a+decomp t = case isVar t of+             Just v -> Var v+             Nothing -> Fun sym args+               where sym = fmap (const ()) t+                     args = arguments t   {-| This function decomposes a term. -} -decompose :: (Decompose f v) => Term f -> DecompTerm f v+decompose :: Decompose f v => Term f -> DecompTerm f v decompose (Term t) = decomp t
src/Data/Comp/DeepSeq.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE GADTs, FlexibleContexts, FlexibleInstances, TypeOperators,-  TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeOperators     #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.DeepSeq@@ -16,24 +19,23 @@  module Data.Comp.DeepSeq     (-     NFDataF(..),-     rnfF'+     NFDataF(..)     )     where -import Data.Comp.Term import Control.DeepSeq+import Data.Comp.Annotation import Data.Comp.Derive-import Data.Foldable-import Prelude hiding (foldr)+import Data.Comp.Term -{-| Fully evaluate a value over a foldable signature. -}-rnfF' :: (Foldable f, NFDataF f, NFData a) => f a -> ()-rnfF' x = foldr seq (rnfF x) x  instance (NFDataF f, NFData a) => NFData (Cxt h f a) where     rnf (Hole x) = rnf x     rnf (Term x) = rnfF x++instance (NFDataF f, NFData a) => NFDataF (f :&: a) where+    rnfF (f :&: a) = rnfF f `seq` rnf a+  $(derive [liftSum] [''NFDataF]) $(derive [makeNFDataF] [''Maybe, ''[], ''(,)])
src/Data/Comp/Derive.hs view
@@ -25,9 +25,6 @@      module Data.Comp.Derive.Equality,      -- ** OrdF      module Data.Comp.Derive.Ordering,-     -- ** Functor-     Functor,-     makeFunctor,      -- ** Foldable      module Data.Comp.Derive.Foldable,      -- ** Traversable@@ -37,7 +34,6 @@      -- ** Arbitrary      module Data.Comp.Derive.Arbitrary,      NFData(..),-     makeNFData,      -- ** DeepSeq      module Data.Comp.Derive.DeepSeq,      -- ** Smart Constructors@@ -48,33 +44,24 @@      liftSum     ) where -import Control.DeepSeq (NFData(..))-import Data.Comp.Derive.Utils (derive, liftSumGen)-import Data.Comp.Derive.HaskellStrict-import Data.Comp.Derive.Foldable-import Data.Comp.Derive.Traversable+import Control.DeepSeq (NFData (..))+import Data.Comp.Derive.Arbitrary import Data.Comp.Derive.DeepSeq-import Data.Comp.Derive.Show-import Data.Comp.Derive.Ordering import Data.Comp.Derive.Equality-import Data.Comp.Derive.Arbitrary-import Data.Comp.Derive.SmartConstructors+import Data.Comp.Derive.Foldable+import Data.Comp.Derive.HaskellStrict+import Data.Comp.Derive.Ordering+import Data.Comp.Derive.Show import Data.Comp.Derive.SmartAConstructors+import Data.Comp.Derive.SmartConstructors+import Data.Comp.Derive.Traversable+import Data.Comp.Derive.Utils (derive, liftSumGen) import Data.Comp.Ops ((:+:), caseF)  import Language.Haskell.TH -import qualified Data.DeriveTH as D-import qualified Data.Derive.All as A -{-| Derive an instance of 'Functor' for a type constructor of any first-order-  kind taking at least one argument. -}-makeFunctor :: Name -> Q [Dec]-makeFunctor = D.derive A.makeFunctor -{-| Derive an instance of 'NFData' for a type constructor. -}-makeNFData :: Name -> Q [Dec]-makeNFData = D.derive A.makeNFData  {-| Given the name of a type class, where the first parameter is a functor,   lift it to sums of functors. Example: @class ShowF f where ...@ is lifted
src/Data/Comp/Derive/Arbitrary.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE GADTs, TemplateHaskell #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Derive.Arbitrary@@ -16,18 +17,12 @@     (      ArbitraryF(..),      makeArbitraryF,-     Arbitrary(..),-     makeArbitrary+     Arbitrary(..)     )where -import Test.QuickCheck import Data.Comp.Derive.Utils hiding (derive) import Language.Haskell.TH-import qualified Data.DeriveTH as D--{-| Derive an instance of 'Arbitrary' for a type constructor. -}-makeArbitrary :: Name -> Q [Dec]-makeArbitrary = D.derive D.makeArbitrary+import Test.QuickCheck  {-| Signature arbitration. An instance @ArbitraryF f@ gives rise to an instance   @Arbitrary (Term f)@. -}@@ -45,14 +40,14 @@   instances of 'Arbitrary'. -} makeArbitraryF :: Name -> Q [Dec] makeArbitraryF dt = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt   let argNames = map (VarT . tyVarBndrName) (tail args)       complType = foldl AppT (ConT name) argNames-      preCond = map (ClassP ''Arbitrary . (: [])) argNames+      preCond = map (mkClassP ''Arbitrary . (: [])) argNames       classType = AppT (ConT ''ArbitraryF) complType   arbitraryDecl <- generateArbitraryFDecl constrs   shrinkDecl <- generateShrinkFDecl constrs-  return [InstanceD preCond classType [arbitraryDecl, shrinkDecl]]+  return [mkInstanceD preCond classType [arbitraryDecl, shrinkDecl]]  {-|   This function generates a declaration of the method 'arbitrary' for the given@@ -64,7 +59,7 @@ {-|   This function generates a declaration of a generator having the given name using   the given constructors, i.e., something like this:-  +   @   \<name\> :: Gen \<type\>   \<name\> = ...@@ -96,10 +91,10 @@                    let build = doE $                                binds ++                                [noBindS [|return $apps|]]-                   if n == 0 +                   if n == 0                       then [|return $apps|]                       else  [| sized $ \ size ->-                                 $(letE [valD +                                 $(letE [valD                                          newSizeP                                          (normalB [|((size - 1) `div` $constrsE ) `max` 0|])                                          [] ]@@ -119,5 +114,5 @@                  binds <- mapM (\(var,resVar) -> bindS (varP resVar) [| $(varE var) : shrink $(varE var) |]) $ zip varNs resVarNs                  let ret = NoBindS $ AppE (VarE 'return) (foldl1 AppE ( ConE constr: map VarE resVarNs ))                      stmtSeq = binds ++ [ret]-                     pat = ConP constr $ map VarP varNs-                 return $ Clause [pat] (NormalB $ AppE (VarE 'tail) (DoE stmtSeq)) []+                     pat = ConP constr [] $ map VarP varNs+                 return $ Clause [pat] (NormalB $ AppE (VarE 'tail) (DoE Nothing stmtSeq)) []
src/Data/Comp/Derive/DeepSeq.hs view
@@ -22,7 +22,6 @@ import Control.DeepSeq import Data.Comp.Derive.Utils import Language.Haskell.TH-import Data.Maybe  {-| Signature normal form. An instance @NFDataF f@ gives rise to an instance   @NFData (Term f)@. -}@@ -33,26 +32,19 @@   kind taking at least one argument. -} makeNFDataF :: Name -> Q [Dec] makeNFDataF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname-  let fArg = VarT . tyVarBndrName $ last args-      argNames = map (VarT . tyVarBndrName) (init args)+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames-      preCond = map (ClassP ''NFData . (: [])) argNames+      preCond = map (mkClassP ''NFData . (: [])) argNames       classType = AppT (ConT ''NFDataF) complType   constrs' <- mapM normalConExp constrs-  rnfFDecl <- funD 'rnfF (rnfFClauses fArg constrs')-  return [InstanceD preCond classType [rnfFDecl]]-      where rnfFClauses fArg = map (genRnfFClause fArg)-            filterFarg excl x-                | excl = Nothing-                | otherwise = Just $ varE x-            mkPat True _ = WildP-            mkPat False x = VarP x-            genRnfFClause fArg (constr, args) = do -              let isFargs = map (==fArg) args-                  n = length args+  rnfFDecl <- funD 'rnfF (rnfFClauses constrs')+  return [mkInstanceD preCond classType [rnfFDecl]]+      where rnfFClauses = map genRnfFClause+            genRnfFClause (constr, args,_) = do+              let n = length args               varNs <- newNames n "x"-              let pat = ConP constr $ zipWith mkPat isFargs varNs-                  allVars = catMaybes $ zipWith filterFarg isFargs varNs+              let pat = ConP constr [] $ map VarP varNs+                  allVars = map varE varNs               body <- foldr (\ x y -> [|rnf $x `seq` $y|]) [| () |] allVars               return $ Clause [pat] (NormalB body) []
src/Data/Comp/Derive/Equality.hs view
@@ -31,30 +31,29 @@   taking at least one argument. -} makeEqF :: Name -> Q [Dec] makeEqF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames-      preCond = map (ClassP ''Eq . (: [])) argNames+      preCond = map (mkClassP ''Eq . (: [])) argNames       classType = AppT (ConT ''EqF) complType   eqFDecl <- funD 'eqF  (eqFClauses constrs)-  return [InstanceD preCond classType [eqFDecl]]+  return [mkInstanceD preCond classType [eqFDecl]]       where eqFClauses constrs = map (genEqClause.abstractConType) constrs                                    ++ defEqClause constrs-            filterFarg fArg ty x = (fArg == ty, x)             defEqClause constrs                 | length constrs  < 2 = []                 | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]-            genEqClause (constr, n) = do +            genEqClause (constr, n) = do               varNs <- newNames n "x"               varNs' <- newNames n "y"-              let pat = ConP constr $ map VarP varNs-                  pat' = ConP constr $ map VarP varNs'+              let pat = ConP constr [] $ map VarP varNs+                  pat' = ConP constr [] $ map VarP varNs'                   vars = map VarE varNs                   vars' = map VarE varNs'                   mkEq x y = let (x',y') = (return x,return y)                              in [| $x' == $y'|]                   eqs = listE $ zipWith mkEq vars vars'-              body <- if n == 0 +              body <- if n == 0                       then [|True|]                       else [|and $eqs|]               return $ Clause [pat, pat'] (NormalB body) []
src/Data/Comp/Derive/Foldable.hs view
@@ -18,29 +18,28 @@      makeFoldable     ) where +import Control.Monad import Data.Comp.Derive.Utils-import Language.Haskell.TH import Data.Foldable-import Control.Monad-import Data.Monoid import Data.Maybe-import qualified Prelude as P (foldl,foldr,foldl1,foldr1)-import Prelude hiding  (foldl,foldr,foldl1,foldr1)+import Data.Monoid+import Language.Haskell.TH+import Prelude hiding (foldl, foldl1, foldr, foldr1)+import qualified Prelude as P (foldl, foldl1, foldr, foldr1)   iter 0 _ e = e iter n f e = iter (n-1) f (f `appE` e) -iter' n f e = run n f e-    where run 0 _ e = e-          run m f e = let f' = iter (m-1) [|fmap|] f-                        in run (m-1) f (f' `appE` e)+iter' 0 _ e = e+iter' m f e = let f' = iter (m-1) [|fmap|] f+              in iter' (m-1) f (f' `appE` e)  {-| Derive an instance of 'Foldable' for a type constructor of any first-order   kind taking at least one argument. -} makeFoldable :: Name -> Q [Dec] makeFoldable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -52,13 +51,13 @@   foldrDecl <- funD 'foldr (map foldrClause constrs')   foldl1Decl <- funD 'foldl1 (map foldl1Clause constrs')   foldr1Decl <- funD 'foldr1 (map foldr1Clause constrs')-  return [InstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl,foldl1Decl,foldr1Decl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl,foldl1Decl,foldr1Decl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getUnaryFArg fArg gadtTy)) args)             filterVar [] _ = Nothing             filterVar [d] x =Just (d, varE x)             filterVar _ _ =  error "functor variable occurring twice in argument type"             filterVars args varNs = catMaybes $ zipWith filterVar args varNs-            mkCPat constr args varNs = ConP constr $ zipWith mkPat args varNs+            mkCPat constr args varNs = ConP constr [] $ zipWith mkPat args varNs             mkPat [] _ = WildP             mkPat _ x = VarP x             mkPatAndVars (constr, args) =@@ -78,7 +77,7 @@                        fp = if null vars then WildP else VarP fn                    body <- case vars of                              [] -> [|mempty|]-                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $ +                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $                                       map (\ (d,z) -> iter' (max (d-1) 0) [|fold|] (f' d `appE` z)) vars                    return $ Clause [fp, pat] (NormalB body) []             foldlClause (pat,vars) =@@ -114,11 +113,11 @@                    let f = varE fn                        fp = case vars of                               (d,_):r-                                  | d > 0 || not (null r) -> VarP fn                              -                              _ -> WildP +                                  | d > 0 || not (null r) -> VarP fn+                              _ -> WildP                        mkComp (d,x) = iter' d [|foldl1 $f|] x-                   body <- case vars of -                             [] -> [|undefined|] +                   body <- case vars of+                             [] -> [|undefined|]                              _ -> P.foldl1 (\ x y -> [|$f $x $y|]) $ map mkComp vars                    return $ Clause [fp, pat] (NormalB body) []             foldr1Clause (pat,vars) =@@ -126,10 +125,10 @@                    let f = varE fn                        fp = case vars of                               (d,_):r-                                  | d > 0 || not (null r) -> VarP fn                              -                              _ -> WildP +                                  | d > 0 || not (null r) -> VarP fn+                              _ -> WildP                        mkComp (d,x) = iter' d [|foldr1 $f|] x-                   body <- case vars of -                             [] -> [|undefined|] +                   body <- case vars of+                             [] -> [|undefined|]                              _ -> P.foldr1 (\ x y -> [|$f $x $y|]) $ map mkComp vars                    return $ Clause [fp, pat] (NormalB body) []
src/Data/Comp/Derive/HaskellStrict.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, CPP #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE ConstraintKinds  #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE TypeOperators    #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Derive.HaskellStrict@@ -19,29 +23,29 @@      , haskellStrict'     ) where +import Control.Monad hiding (mapM, sequence) import Data.Comp.Derive.Utils-import Language.Haskell.TH-import Data.Maybe-import Data.Comp.Thunk import Data.Comp.Sum+import Data.Comp.Thunk+import Data.Foldable hiding (any, or)+import Data.Maybe import Data.Traversable-import Data.Foldable hiding (any,or)-import Control.Monad hiding (mapM, sequence)-import qualified Prelude as P (foldl, foldr, mapM, all)-import Prelude hiding  (foldl, foldr,mapM, sequence)+import Language.Haskell.TH+import Prelude hiding (foldl, foldr, mapM, sequence)+import qualified Prelude as P (all, foldl, foldr, mapM)   class HaskellStrict f where     thunkSequence :: (Monad m) => f (TermT m g) -> m (f (TermT m g))-    thunkSequenceInject :: (Monad m, f :<: g) => f (TermT m g) -> TermT m g+    thunkSequenceInject :: (Monad m, f :<: m :+: g) => f (TermT m g) -> TermT m g     thunkSequenceInject t = thunk $ liftM inject $ thunkSequence t-    thunkSequenceInject' :: (Monad m, f :<: g) => f (TermT m g) -> TermT m g+    thunkSequenceInject' :: (Monad m, f :<: m :+: g) => f (TermT m g) -> TermT m g     thunkSequenceInject' = thunkSequenceInject -haskellStrict :: (Monad m, HaskellStrict f, f :<: g) => f (TermT m g) -> TermT m g+haskellStrict :: (Monad m, HaskellStrict f, f :<: m :+: g) => f (TermT m g) -> TermT m g haskellStrict = thunkSequenceInject -haskellStrict' :: (Monad m, HaskellStrict f, f :<: g) => f (TermT m g) -> TermT m g+haskellStrict' :: (Monad m, HaskellStrict f, f :<: m :+: g) => f (TermT m g) -> TermT m g haskellStrict' = thunkSequenceInject'  deepThunk d = iter d [|thunkSequence|]@@ -53,7 +57,7 @@   first-order kind taking at least one argument. -} makeHaskellStrict :: Name -> Q [Dec] makeHaskellStrict fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -64,26 +68,31 @@      sequenceDecl <- valD (varP 'thunkSequence) (normalB [|return|]) []      injectDecl <- valD (varP 'thunkSequenceInject) (normalB [|inject|]) []      injectDecl' <- valD (varP 'thunkSequenceInject') (normalB [|inject|]) []-     return [InstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]+     return [mkInstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]    else do      (sc',matchPat,ic') <- liftM unzip3 $ P.mapM mkClauses constrs_      xn <- newName "x"      doThunk <- [|thunk|]      let sequenceDecl = FunD 'thunkSequence sc'-         injectDecl = FunD 'thunkSequenceInject [Clause [VarP xn] (NormalB (doThunk `AppE` CaseE (VarE xn) matchPat)) []] +         injectDecl = FunD 'thunkSequenceInject [Clause [VarP xn] (NormalB (doThunk `AppE` CaseE (VarE xn) matchPat)) []]          injectDecl' = FunD 'thunkSequenceInject' ic'-     return [InstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]-      where isFarg fArg (constr, args) = (constr, map (containsStr fArg) args)-            containsStr _ (NotStrict,_) = []+     return [mkInstanceD [] classType [sequenceDecl, injectDecl, injectDecl']]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (containsStr (getUnaryFArg fArg gadtTy)) args)+            +#if __GLASGOW_HASKELL__ < 800             containsStr fArg (IsStrict,ty) = ty `containsType'` fArg-#if __GLASGOW_HASKELL__ > 702             containsStr fArg (Unpacked,ty) = ty `containsType'` fArg+#else+            containsStr fArg (Bang _ SourceStrict,ty) = ty `containsType'` fArg+            containsStr fArg (Bang SourceUnpack _,ty) = ty `containsType'` fArg #endif+            containsStr _ _ = []+             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"             filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs-            mkCPat constr varNs = ConP constr $ map mkPat varNs+            mkCPat constr varNs = ConP constr [] $ map mkPat varNs             mkPat = VarP             mkClauses (constr, args) =                 do varNs <- newNames (length args) "x"@@ -91,7 +100,7 @@                        fvars = catMaybes $ filterVars args varNs (curry Just) (const Nothing)                        allVars = map varE varNs                        conAp = P.foldl appE (conE constr) allVars-                       conBind (d, x) y = [| $(deepThunk d `appE` (varE x))  >>= $(lamE [varP x] y)|]+                       conBind (d, x) y = [| $(deepThunk d `appE` varE x)  >>= $(lamE [varP x] y)|]                    bodySC' <- P.foldr conBind [|return $conAp|] fvars                    let sc' = Clause [pat] (NormalB bodySC') []                    bodyMatch <- case fvars of
− src/Data/Comp/Derive/Injections.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Derive.Injections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature injections.--------------------------------------------------------------------------------------module Data.Comp.Derive.Injections-    (-     injn,-     injectn,-     deepInjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Term-import Data.Comp.Algebra (CxtFun, appSigFun)-import Data.Comp.Ops ((:+:)(..), (:<:)(..))--injn :: Int -> Q [Dec]-injn n = do-  let i = mkName $ "inj" ++ show n-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let xvar = mkName "x"-  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ sigD i (genSig fvars gvar avar) : d-    where genSig fvars gvar avar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = arrowT `appT` (tp `appT` varT avar)-                             `appT` (varT gvar `appT` varT avar)-            forallT (map PlainTV $ gvar : avar : fvars)-                    (sequence cxt) tp'-          genDecl x n = [| case $(varE x) of-                             Inl x -> $(varE $ mkName "inj") x-                             Inr x -> $(varE $ mkName $ "inj" ++-                                        if n > 2 then show (n - 1) else "") x |]-injectn :: Int -> Q [Dec]-injectn n = do-  let i = mkName ("inject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar avar) : d-    where genSig fvars gvar avar = do-            let hvar = mkName "h"-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar-                                 `appT` varT avar-            let tp'' = arrowT `appT` (tp `appT` tp') `appT` tp'-            forallT (map PlainTV $ hvar : gvar : avar : fvars)-                    (sequence cxt) tp''-          genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]--deepInjectn :: Int -> Q [Dec]-deepInjectn n = do-  let i = mkName ("deepInject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar) : d-    where genSig fvars gvar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let cxt' = classP ''Functor [tp]-            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar-            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
src/Data/Comp/Derive/Ordering.hs view
@@ -20,8 +20,8 @@ import Data.Comp.Derive.Equality import Data.Comp.Derive.Utils -import Data.Maybe import Data.List+import Data.Maybe import Language.Haskell.TH hiding (Cxt)  {-| Signature ordering. An instance @OrdF f@ gives rise to an instance@@ -29,7 +29,7 @@ class EqF f => OrdF f where     compareF :: Ord a => f a -> f a -> Ordering -    + compList :: [Ordering] -> Ordering compList = fromMaybe EQ . find (/= EQ) @@ -37,15 +37,15 @@   taking at least one argument. -} makeOrdF :: Name -> Q [Dec] makeOrdF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames-      preCond = map (ClassP ''Ord . (: [])) argNames+      preCond = map (mkClassP ''Ord . (: [])) argNames       classType = AppT (ConT ''OrdF) complType   eqAlgDecl <- funD 'compareF  (compareFClauses constrs)-  return [InstanceD preCond classType [eqAlgDecl]]+  return [mkInstanceD preCond classType [eqAlgDecl]]       where compareFClauses [] = []-            compareFClauses constrs = +            compareFClauses constrs =                 let constrs' = map abstractConType constrs `zip` [1..]                     constPairs = [(x,y)| x<-constrs', y <- constrs']                 in map genClause constPairs@@ -53,11 +53,11 @@                 | n == m = genEqClause c                 | n < m = genLtClause c d                 | otherwise = genGtClause c d-            genEqClause (constr, n) = do +            genEqClause (constr, n) = do               varNs <- newNames n "x"               varNs' <- newNames n "y"-              let pat = ConP constr $ map VarP varNs-                  pat' = ConP constr $ map VarP varNs'+              let pat = ConP constr [] $ map VarP varNs+                  pat' = ConP constr [] $ map VarP varNs'                   vars = map VarE varNs                   vars' = map VarE varNs'                   mkEq x y = let (x',y') = (return x,return y)
− src/Data/Comp/Derive/Projections.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE TemplateHaskell, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Derive.Projections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature projections.--------------------------------------------------------------------------------------module Data.Comp.Derive.Projections-    (-     projn,-     projectn,-     deepProjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Control.Monad (liftM)-import Data.Traversable (Traversable)-import Data.Comp.Term-import Data.Comp.Algebra (CxtFunM, appSigFunM')-import Data.Comp.Ops ((:+:)(..), (:<:)(..))--projn :: Int -> Q [Dec]-projn n = do-  let p = mkName $ "proj" ++ show n-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar) []]]-  sequence $ (sigD p $ genSig gvars avar) : d-    where genSig gvars avar = do-            let fvar = mkName "f"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = arrowT `appT` (varT fvar `appT` varT avar)-                             `appT` (conT ''Maybe `appT`-                                     (tp `appT` varT avar))-            forallT (map PlainTV $ fvar : avar : gvars) (sequence cxt) tp'-          genDecl x [g] a =-            [| liftM inj (proj $(varE x)-                          :: Maybe ($(varT g `appT` varT a))) |]-          genDecl x (g:gs) a =-            [| case (proj $(varE x)-                         :: Maybe ($(varT g `appT` varT a))) of-                 Just y -> Just $ inj y-                 _ -> $(genDecl x gs a) |]-          genDecl _ _ _ = error "genDecl called with empty list"--projectn :: Int -> Q [Dec]-projectn n = do-  let p = mkName ("project" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ (sigD p $ genSig gvars avar) : d-    where genSig gvars avar = do-            let fvar = mkName "f"-            let hvar = mkName "h"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar-                                 `appT` varT avar-            let tp'' = arrowT `appT` tp'-                              `appT` (conT ''Maybe `appT` (tp `appT` tp'))-            forallT (map PlainTV $ hvar : fvar : avar : gvars)-                    (sequence cxt) tp''-          genDecl x n = [| case $(varE x) of-                             Hole _ -> Nothing-                             Term t -> $(varE $ mkName $ "proj" ++ show n) t |]--deepProjectn :: Int -> Q [Dec]-deepProjectn n = do-  let p = mkName ("deepProject" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let d = [funD p [clause [] (normalB $ genDecl n) []]]-  sequence $ (sigD p $ genSig gvars) : d-    where genSig gvars = do-            let fvar = mkName "f"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let cxt' = classP ''Traversable [tp]-            let tp' = conT ''CxtFunM `appT` conT ''Maybe-                                     `appT` varT fvar `appT` tp-            forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
src/Data/Comp/Derive/Show.hs view
@@ -15,7 +15,9 @@ module Data.Comp.Derive.Show     (      ShowF(..),-     makeShowF+     makeShowF,+     ShowConstr(..),+     makeShowConstr     ) where  import Data.Comp.Derive.Utils@@ -25,36 +27,72 @@   @Show (Term f)@. -} class ShowF f where     showF :: f String -> String-             -showConstr :: String -> [String] -> String-showConstr con [] = con-showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")" +showCon :: String -> [String] -> String+showCon con [] = con+showCon con args = "(" ++ con ++ " " ++ unwords args ++ ")"+ {-| Derive an instance of 'ShowF' for a type constructor of any first-order kind   taking at least one argument. -} makeShowF :: Name -> Q [Dec] makeShowF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames-      preCond = map (ClassP ''Show . (: [])) argNames+      preCond = map (mkClassP ''Show . (: [])) argNames       classType = AppT (ConT ''ShowF) complType   constrs' <- mapM normalConExp constrs   showFDecl <- funD 'showF (showFClauses fArg constrs')-  return [InstanceD preCond classType [showFDecl]]+  return [mkInstanceD preCond classType [showFDecl]]       where showFClauses fArg = map (genShowFClause fArg)             filterFarg fArg ty x = (fArg == ty, varE x)             mkShow :: (Bool, ExpQ) -> ExpQ             mkShow (isFArg, var)                 | isFArg = var                 | otherwise = [| show $var |]-            genShowFClause fArg (constr, args) = do +            genShowFClause fArg (constr, args, gadtTy) = do               let n = length args               varNs <- newNames n "x"-              let pat = ConP constr $ map VarP varNs-                  allVars = zipWith (filterFarg fArg) args varNs+              let pat = ConP constr [] $ map VarP varNs+                  allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs                   shows = listE $ map mkShow allVars                   conName = nameBase constr-              body <- [|showConstr conName $shows|]+              body <- [|showCon conName $shows|]+              return $ Clause [pat] (NormalB body) []++{-| Constructor printing. -}+class ShowConstr f where+    showConstr :: f a -> String++showCon' :: String -> [String] -> String+showCon' con args = unwords $ con : filter (not.null) args++{-| Derive an instance of 'showConstr' for a type constructor of any first-order kind+  taking at least one argument. -}+makeShowConstr :: Name -> Q [Dec]+makeShowConstr fname = do+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  let fArg = VarT . tyVarBndrName $ last args+      argNames = map (VarT . tyVarBndrName) (init args)+      complType = foldl AppT (ConT name) argNames+      preCond = map (mkClassP ''Show . (: [])) argNames+      classType = AppT (ConT ''ShowConstr) complType+  constrs' <- mapM normalConExp constrs+  showConstrDecl <- funD 'showConstr (showConstrClauses fArg constrs')+  return [mkInstanceD preCond classType [showConstrDecl]]+      where showConstrClauses fArg = map (genShowConstrClause fArg)+            filterFarg fArg ty x = (fArg == ty, varE x)+            mkShow :: (Bool, ExpQ) -> ExpQ+            mkShow (isFArg, var)+                | isFArg = [| "" |]+                | otherwise = [| show $var |]+            genShowConstrClause fArg (constr, args, gadtTy) = do+              let n = length args+              varNs <- newNames n "x"+              let pat = ConP constr [] $ map VarP varNs+                  allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs+                  shows = listE $ map mkShow allVars+                  conName = nameBase constr+              body <- [|showCon' conName $shows|]               return $ Clause [pat] (NormalB body) []
src/Data/Comp/Derive/SmartAConstructors.hs view
@@ -17,12 +17,12 @@      smartAConstructors     ) where -import Language.Haskell.TH hiding (Cxt)+import Control.Monad+import Data.Comp.Annotation import Data.Comp.Derive.Utils import Data.Comp.Sum import Data.Comp.Term-import Data.Comp.Annotation-import Control.Monad+import Language.Haskell.TH hiding (Cxt)  {-| Derive smart constructors with products for a type constructor of any   parametric kind taking at least one argument. The smart constructors are@@ -30,13 +30,13 @@   inserted. -} smartAConstructors :: Name -> Q [Dec] smartAConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let cons = map abstractConType constrs-    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons-        where genSmartConstr targs tname (name, args) = do+    liftM concat $ mapM genSmartConstr cons+        where genSmartConstr   (name, args) = do                 let bname = nameBase name-                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args-              genSmartConstr' targs tname sname name args = do+                genSmartConstr'  (mkName $ "iA" ++ bname) name args+              genSmartConstr'  sname name args = do                 varNs <- newNames args "x"                 varPr <- newName "_p"                 let pats = map varP (varPr : varNs)
src/Data/Comp/Derive/SmartConstructors.hs view
@@ -12,23 +12,23 @@ -- -------------------------------------------------------------------------------- -module Data.Comp.Derive.SmartConstructors +module Data.Comp.Derive.SmartConstructors     (      smartConstructors     ) where -import Language.Haskell.TH hiding (Cxt)+import Control.Monad import Data.Comp.Derive.Utils import Data.Comp.Sum import Data.Comp.Term-import Control.Monad+import Language.Haskell.TH hiding (Cxt)  {-| Derive smart constructors for a type constructor of any first-order kind  taking at least one argument. The smart constructors are similar to the  ordinary constructors, but an 'inject' is automatically inserted. -} smartConstructors :: Name -> Q [Dec] smartConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let cons = map abstractConType constrs     liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons         where genSmartConstr targs tname (name, args) = do@@ -52,8 +52,8 @@                     h = varT hvar                     a = varT avar                     ftype = foldl appT (conT tname) (map varT targs')-                    constr = classP ''(:<:) [ftype, f]+                    constr = (conT ''(:<:) `appT` ftype) `appT` f                     typ = foldl appT (conT ''Cxt) [h, f, a]-                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ+                    typeSig = forallT (map (\ v -> PlainTV v SpecifiedSpec) vars) (sequence [constr]) typ                 sigD sname typeSig               genSig _ _ _ _ = []
src/Data/Comp/Derive/Traversable.hs view
@@ -18,29 +18,28 @@      makeTraversable     ) where +import Control.Applicative+import Control.Monad hiding (mapM, sequence) import Data.Comp.Derive.Utils-import Language.Haskell.TH+import Data.Foldable hiding (any, or) import Data.Maybe import Data.Traversable-import Data.Foldable hiding (any,or)-import Control.Applicative-import Control.Monad hiding (mapM, sequence)+import Language.Haskell.TH+import Prelude hiding (foldl, foldr, mapM, sequence) import qualified Prelude as P (foldl, foldr, mapM)-import Prelude hiding  (foldl, foldr,mapM, sequence)  iter 0 _ e = e iter n f e = iter (n-1) f (f `appE` e) -iter' n f e = run n f e-    where run 0 _ e = e-          run m f e = let f' = iter (m-1) [|fmap|] f-                        in run (m-1) f (f' `appE` e)+iter' 0 _ e = e+iter' m f e = let f' = iter (m-1) [|fmap|] f+              in iter' (m-1) f (f' `appE` e)  {-| Derive an instance of 'Traversable' for a type constructor of any   first-order kind taking at least one argument. -} makeTraversable :: Name -> Q [Dec] makeTraversable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let fArg = VarT . tyVarBndrName $ last args       argNames = map (VarT . tyVarBndrName) (init args)       complType = foldl AppT (ConT name) argNames@@ -50,27 +49,27 @@   sequenceADecl <- funD 'sequenceA (map sequenceAClause constrs')   mapMDecl <- funD 'mapM (map mapMClause constrs')   sequenceDecl <- funD 'sequence (map sequenceClause constrs')-  return [InstanceD [] classType [traverseDecl, sequenceADecl, mapMDecl,sequenceDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [traverseDecl, sequenceADecl, mapMDecl,sequenceDecl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getUnaryFArg fArg gadtTy)) args)             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"             filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs-            mkCPat constr varNs = ConP constr $ map mkPat varNs+            mkCPat constr varNs = ConP constr [] $ map mkPat varNs             mkPat = VarP             mkPatAndVars (constr, args) =                 do varNs <- newNames (length args) "x"                    return (conE constr, mkCPat constr varNs,                            \f g -> filterVars args varNs (\ d x -> f d (varE x)) (g . varE),                            any (not . null) args, map varE varNs, catMaybes $ filterVars args varNs (curry Just) (const Nothing))-            traverseClause (con, pat,vars',hasFargs,_,_) =+            traverseClause (con, pat,vars',hasFargs,_allVars,_fVars) =                 do fn <- newName "f"                    let f = varE fn                        fp = if hasFargs then VarP fn else WildP                        vars = vars' (\d x -> iter d [|traverse|] f `appE` x) (\x -> [|pure $x|])                    body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars                    return $ Clause [fp, pat] (NormalB body) []-            sequenceAClause (con, pat,vars',hasFargs,_,_) =+            sequenceAClause (con, pat,vars',_hasFargs,_,_) =                 do let vars = vars' (\d x -> iter' d [|sequenceA|] x) (\x -> [|pure $x|])                    body <- P.foldl (\ x y -> [|$x <*> $y|]) [|pure $con|] vars                    return $ Clause [pat] (NormalB body) []@@ -85,7 +84,7 @@                        conBind (d,x) y = [| $(iter d [|mapM|] f) $(varE x)  >>= $(lamE [varP x] y)|]                    body <- P.foldr conBind [|return $conAp|] fvars                    return $ Clause [fp, pat] (NormalB body) []-            sequenceClause (con, pat,_,hasFargs,allVars, fvars) =+            sequenceClause (con, pat,_vars',_hasFargs,allVars, fvars) =                 do let conAp = P.foldl appE con allVars                        conBind (d, x) y = [| $(iter' d [|sequence|] (varE x))  >>= $(lamE [varP x] y)|]                    body <- P.foldr conBind [|return $conAp|] fvars
src/Data/Comp/Derive/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- |@@ -15,61 +16,87 @@ module Data.Comp.Derive.Utils where  +import Control.Monad import Language.Haskell.TH import Language.Haskell.TH.Syntax-import Control.Monad import Language.Haskell.TH.ExpandSyns --- reportError is introduced only from version 7.6 of GHC-#if __GLASGOW_HASKELL__ < 706-reportError :: String -> Q ()-reportError = report True-#endif+data DataInfo = forall flag . DataInfo Cxt Name [TyVarBndr flag] [Con] [DerivClause]  + {-|-  This is the @Q@-lifted version of 'abstractNewtypeQ.+  This is the @Q@-lifted version of 'abstractNewtype. -}-abstractNewtypeQ :: Q Info -> Q Info+abstractNewtypeQ :: Q Info -> Q (Maybe DataInfo) abstractNewtypeQ = liftM abstractNewtype  {-|   This function abstracts away @newtype@ declaration, it turns them into   @data@ declarations. -}-abstractNewtype :: Info -> Info-abstractNewtype (TyConI (NewtypeD cxt name args constr derive))-    = TyConI (DataD cxt name args [constr] derive)-abstractNewtype owise = owise+abstractNewtype :: Info -> Maybe DataInfo+abstractNewtype (TyConI (NewtypeD cxt name args _ constr derive))+    = Just (DataInfo cxt name args [constr] derive)+abstractNewtype (TyConI (DataD cxt name args _ constrs derive))+    = Just (DataInfo cxt name args constrs derive)+abstractNewtype _ = Nothing -{-|-  This function provides the name and the arity of the given data constructor.+{-| This function provides the name and the arity of the given data+constructor, and if it is a GADT also its type. -}-normalCon :: Con -> (Name,[StrictType])-normalCon (NormalC constr args) = (constr, args)-normalCon (RecC constr args) = (constr, map (\(_,s,t) -> (s,t)) args)-normalCon (InfixC a constr b) = (constr, [a,b])+normalCon :: Con -> (Name,[StrictType], Maybe Type)+normalCon (NormalC constr args) = (constr, args, Nothing)+normalCon (RecC constr args) = (constr, map (\(_,s,t) -> (s,t)) args, Nothing)+normalCon (InfixC a constr b) = (constr, [a,b], Nothing) normalCon (ForallC _ _ constr) = normalCon constr+normalCon (GadtC (constr:_) args typ) = (constr,args,Just typ)+normalCon _ = error "missing case for 'normalCon'" +normalCon' :: Con -> (Name,[Type], Maybe Type)+normalCon' con = (n, map snd ts, t)+  where (n, ts, t) = normalCon con+       -normalCon' :: Con -> (Name,[Type])-normalCon' = fmap (map snd) . normalCon +-- -- | Same as normalCon' but expands type synonyms.+-- normalConExp :: Con -> Q (Name,[Type])+-- normalConExp c = do+--   let (n,ts,t) = normalCon' c+--   ts' <- mapM expandSyns ts+--   return (n, ts')  -- | Same as normalCon' but expands type synonyms.-normalConExp :: Con -> Q (Name,[Type])-normalConExp c = do -  let (n,ts) = normalCon' c-  ts' <- mapM expandSyns ts-  return (n, ts')+normalConExp :: Con -> Q (Name,[Type], Maybe Type)+normalConExp c = do+  let (n,ts,t) = normalCon' c+  return (n, ts,t)   -- | Same as normalConExp' but retains strictness annotations.-normalConStrExp :: Con -> Q (Name,[StrictType])-normalConStrExp c = do -  let (n,ts) = normalCon c+normalConStrExp :: Con -> Q (Name,[StrictType], Maybe Type)+normalConStrExp c = do+  let (n,ts,t) = normalCon c   ts' <- mapM (\ (st,ty) -> do ty' <- expandSyns ty; return (st,ty')) ts-  return (n, ts')+  return (n, ts',t) +-- | Auxiliary function to extract the first argument of a binary type+-- application (the second argument of this function). If the second+-- argument is @Nothing@ or not of the right shape, the first argument+-- is returned as a default. +getBinaryFArg :: Type -> Maybe Type -> Type+getBinaryFArg _ (Just (AppT (AppT _ t)  _)) = t+getBinaryFArg def _ = def++-- | Auxiliary function to extract the first argument of a type+-- application (the second argument of this function). If the second+-- argument is @Nothing@ or not of the right shape, the first argument+-- is returned as a default.+getUnaryFArg :: Type -> Maybe Type -> Type+getUnaryFArg _ (Just (AppT _ t)) = t+getUnaryFArg def _ = def+++ {-|   This function provides the name and the arity of the given data constructor. -}@@ -78,12 +105,14 @@ abstractConType (RecC constr args) = (constr, length args) abstractConType (InfixC _ constr _) = (constr, 2) abstractConType (ForallC _ _ constr) = abstractConType constr+abstractConType (GadtC (constr:_) args _typ) = (constr,length args) -- Only first Name+abstractConType _ = error "missing case for 'abstractConType'"  {-|   This function returns the name of a bound type variable -}-tyVarBndrName (PlainTV n) = n-tyVarBndrName (KindedTV n _) = n+tyVarBndrName (PlainTV n _) = n+tyVarBndrName (KindedTV n _ _) = n  containsType :: Type -> Type -> Bool containsType s t@@ -125,6 +154,26 @@ derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec] derive ders names = liftM concat $ sequence [der name | der <- ders, name <- names] +{-| Apply a class name to type arguments to construct a type class+    constraint.+-}++mkClassP :: Name -> [Type] -> Type+mkClassP name = foldl AppT (ConT name)++{-| This function checks whether the given type constraint is an+equality constraint. If so, the types of the equality constraint are+returned. -}++isEqualP :: Type -> Maybe (Type, Type)+isEqualP (AppT (AppT EqualityT x) y) = Just (x, y)+isEqualP _ = Nothing++mkInstanceD :: Cxt -> Type -> [Dec] -> Dec+mkInstanceD cxt ty decs = InstanceD Nothing cxt ty decs+++ -- | This function lifts type class instances over sums -- ofsignatures. To this end it assumes that it contains only methods -- with types of the form @f t1 .. tn -> t@ where @f@ is the signature@@ -146,7 +195,7 @@   ClassI (ClassD _ name targs_ _ decs) _ <- reify fname   let targs = map tyVarBndrName targs_   splitM <- findSig targs decs-  case splitM of +  case splitM of     Nothing -> do reportError $ "Class " ++ show name ++ " cannot be lifted to sums!"                   return []     Just (ts1_, ts2_) -> do@@ -154,12 +203,12 @@       let g = VarT $ mkName "g"       let ts1 = map VarT ts1_       let ts2 = map VarT ts2_-      let cxt = [ClassP name (ts1 ++ f : ts2),-                 ClassP name (ts1 ++ g : ts2)]+      let cxt = [mkClassP name (ts1 ++ f : ts2),+                 mkClassP name (ts1 ++ g : ts2)]       let tp = ((ConT sumName `AppT` f) `AppT` g)       let complType = foldl AppT (foldl AppT (ConT name) ts1 `AppT` tp) ts2       decs' <- sequence $ concatMap decl decs-      return [InstanceD cxt complType decs']+      return [mkInstanceD cxt complType decs']         where decl :: Dec -> [DecQ]               decl (SigD f _) = [funD f [clause f]]               decl _ = []@@ -167,8 +216,8 @@               clause f = do x <- newName "x"                             let b = NormalB (VarE caseName `AppE` VarE f `AppE` VarE f `AppE` VarE x)                             return $ Clause [VarP x] b []-                          -                          ++ findSig :: [Name] -> [Dec] -> Q (Maybe ([Name],[Name])) findSig targs decs = case map run decs of                        []  -> return Nothing@@ -177,7 +226,7 @@                                     Nothing -> return Nothing                                     Just n -> return $ splitNames n targs   where run :: Dec -> Q (Maybe Name)-        run (SigD _ ty) = do +        run (SigD _ ty) = do           ty' <- expandSyns ty           return $ getSig False ty'         run _ = return Nothing@@ -186,7 +235,7 @@         getSig True (AppT ty _) = getSig True ty         getSig True (VarT n) = Just n         getSig _ _ = Nothing-        splitNames y (x:xs) +        splitNames y (x:xs)           | y == x = Just ([],xs)           | otherwise = do (xs1,xs2) <- splitNames y xs                            return (x:xs1,xs2)
src/Data/Comp/Desugar.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,-  UndecidableInstances, OverlappingInstances, TypeOperators #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Desugar@@ -26,7 +30,7 @@  -- We make the lifting to sums explicit in order to make the Desugar -- class work with the default instance declaration further below.-instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where+instance {-# OVERLAPPABLE #-} (Desugar f h, Desugar g h) => Desugar (f :+: g) h where     desugHom = caseF desugHom desugHom  -- |Desugar a term.@@ -40,5 +44,5 @@ desugarA = appHom (propAnn desugHom)  -- |Default desugaring instance.-instance (Functor f, Functor g, f :<: g) => Desugar f g where+instance {-# OVERLAPPABLE #-} (Functor f, Functor g, f :<: g) => Desugar f g where     desugHom = simpCxt . inj
src/Data/Comp/Equality.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators   #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Equality@@ -18,14 +20,13 @@      eqMod,     ) where -import Data.Comp.Term-import Data.Comp.Sum-import Data.Comp.Ops+import Control.Monad hiding (mapM_) import Data.Comp.Derive.Equality import Data.Comp.Derive.Utils+import Data.Comp.Ops+import Data.Comp.Term import Data.Foldable-import Control.Monad hiding (mapM_)-import Prelude hiding (mapM_, all)+import Prelude hiding (all, mapM_)  -- instance (EqF f, Eq p) => EqF (f :*: p) where --    eqF (v1 :*: p1) (v2 :*: p2) = p1 == p2 && v1 `eqF` v2
src/Data/Comp/Generic.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE GADTs, ScopedTypeVariables, TypeOperators #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}  -------------------------------------------------------------------------------- -- |@@ -16,15 +20,29 @@  module Data.Comp.Generic where -import Data.Comp.Term+import Control.Monad hiding (mapM)+import Data.Comp.Algebra import Data.Comp.Sum+import Data.Comp.Term import Data.Foldable import Data.Maybe import Data.Traversable-import GHC.Exts-import Control.Monad hiding (mapM)-import Prelude hiding (foldl,mapM)+import GHC.Exts (build)+import Prelude hiding (foldl, mapM) ++-- | This function returns the subterm of a given term at the position+-- specified by the given path or @Nothing@ if the input term has no+-- such subterm++getSubterm :: (Functor g, Foldable g) => [Int] -> Term g -> Maybe (Term g)+getSubterm path t = cata alg t path where+    alg :: (Functor g, Foldable g) => Alg g ([Int] -> Maybe (Cxt h g a))+    alg t [] = Just $ Term $ fmap ((fromJust) . ($ [])) t+    alg t (i:is) = case drop i (toList t) of+                     [] -> Nothing+                     x : _ -> x is+ -- | This function returns a list of all subterms of the given -- term. This function is similar to Uniplate's @universe@ function. subterms :: forall f . Foldable f => Term f -> [Term f]@@ -60,11 +78,11 @@ -- | Monadic version of 'transform'. transformM :: (Traversable f, Monad m) =>              (Term f -> m (Term f)) -> Term f -> m (Term f)-transformM  f = run +transformM  f = run     where run t = f =<< liftM Term (mapM run $ unTerm t)  query :: Foldable f => (Term f -> r) -> (r -> r -> r) -> Term f -> r-query q c = run +query q c = run     where run i@(Term t) = foldl (\s x -> s `c` run x) (q i) t -- query q c i@(Term t) = foldl (\s x -> s `c` query q c x) (q i) t
+ src/Data/Comp/Mapping.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Mapping+-- Copyright   :  (c) 2014 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides functionality to construct mappings from+-- positions in a functorial value.+--+--------------------------------------------------------------------------------++module Data.Comp.Mapping+    ( Numbered (..)+    , unNumbered+    , number+    , Traversable ()+    , Mapping (..)+    , prodMap+    , lookupNumMap+    , lookupNumMap'+    , NumMap) where++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.Traversable+import Data.Foldable++import Control.Monad.State+import Prelude hiding (mapM)+++-- | This type is used for numbering components of a functorial value.+data Numbered a = Numbered Int a++unNumbered :: Numbered a -> a+unNumbered (Numbered _ x) = x+++-- | This function numbers the components of the given functorial+-- value with consecutive integers starting at 0.+number :: Traversable f => f a -> f (Numbered a)+number x = evalState (mapM run x) 0 where+  run b = do n <- get+             put (n+1)+             return $ Numbered n b+++infix 1 |->+infixr 0 &+++class Functor m => Mapping m k | m -> k where+    -- | left-biased union of two mappings.+    (&) :: m v -> m v -> m v++    -- | This operator constructs a singleton mapping.+    (|->) :: k -> v -> m v++    -- | This is the empty mapping.+    empty :: m v++    -- | This function constructs the pointwise product of two maps each+    -- with a default value.+    prodMapWith :: (v1 -> v2 -> v) -> v1 -> v2 -> m v1 -> m v2 -> m v++    -- | Returns the value at the given key or returns the given+    -- default when the key is not an element of the map.+    findWithDefault :: a -> k -> m a -> a++-- | This function constructs the pointwise product of two maps each+-- with a default value.+prodMap :: Mapping m k => v1 -> v2 -> m v1 -> m v2 -> m (v1, v2)+prodMap = prodMapWith (,)++newtype NumMap k v = NumMap (IntMap v) deriving (Functor,Foldable,Traversable)++lookupNumMap :: a -> Int -> NumMap t a -> a+lookupNumMap d k (NumMap m) = IntMap.findWithDefault d k m++lookupNumMap' :: Int -> NumMap t a -> Maybe a+lookupNumMap' k (NumMap m) = IntMap.lookup k m++instance Mapping (NumMap k) (Numbered k) where+    NumMap m1 & NumMap m2 = NumMap (IntMap.union m1 m2)+    Numbered k _ |-> v = NumMap $ IntMap.singleton k v+    empty = NumMap IntMap.empty++    findWithDefault d (Numbered i _) m = lookupNumMap d i m++    prodMapWith f p q (NumMap mp) (NumMap mq) = NumMap $ IntMap.mergeWithKey merge +                                          (IntMap.map (`f` q)) (IntMap.map (p `f`)) mp mq+      where merge _ p q = Just (p `f` q)
src/Data/Comp/Matching.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE GADTs, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Matching@@ -19,15 +21,15 @@      module Data.Comp.Variables     ) where -import Data.Comp.Term import Data.Comp.Equality+import Data.Comp.Term import Data.Comp.Variables-import qualified Data.Map as Map+import Data.Foldable import Data.Map (Map)+import qualified Data.Map as Map import Data.Traversable-import Data.Foldable -import Prelude hiding (mapM_, mapM, all)+import Prelude hiding (all, mapM, mapM_)  {-| This is an auxiliary function for implementing 'matchCxt'. It behaves similarly as 'match' but is oblivious to non-linearity. Therefore, the@@ -58,7 +60,7 @@  matchCxt :: (Ord v,EqF f, Eq (Cxt h f a), Functor f, Foldable f)          => Context f v -> Cxt h f a -> Maybe (CxtSubst h a f v)-matchCxt c1 c2 = do +matchCxt c1 c2 = do   res <- matchCxt' c1 c2   let insts = Map.elems res   mapM_ checkEq insts
src/Data/Comp/Multi.hs view
@@ -8,7 +8,7 @@ -- Portability :  non-portable (GHC Extensions) -- -- This module defines the infrastructure necessary to use--- /Generalised Compositional Data Types/. Generalised Compositional Data Types +-- /Generalised Compositional Data Types/. Generalised Compositional Data Types -- is an extension of Compositional Data Types with mutually recursive -- data types, and more generally GADTs. Examples of usage are bundled with the -- package in the library @examples\/Examples\/Multi@.@@ -24,17 +24,17 @@   , module Data.Comp.Multi.Generic     ) where -import Data.Comp.Multi.HFunctor-import Data.Comp.Multi.Term import Data.Comp.Multi.Algebra-import Data.Comp.Multi.Sum import Data.Comp.Multi.Annotation import Data.Comp.Multi.Equality import Data.Comp.Multi.Generic+import Data.Comp.Multi.HFunctor+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Term  {- $ex1-The example illustrates how to use generalised compositional data types -to implement a small expression language, with a sub language of values, and +The example illustrates how to use generalised compositional data types+to implement a small expression language, with a sub language of values, and an evaluation function mapping expressions to values.  The following language extensions are needed in order to run the example:@@ -45,7 +45,7 @@ > import Data.Comp.Multi > import Data.Comp.Multi.Show () > import Data.Comp.Multi.Derive-> +> > -- Signature for values and operators > data Value e l where >   Const  ::        Int -> Value e Int@@ -54,41 +54,41 @@ >   Add, Mult  :: e Int -> e Int   -> Op e Int >   Fst        ::          e (s,t) -> Op e s >   Snd        ::          e (s,t) -> Op e t-> +> > -- Signature for the simple expression language > type Sig = Op :+: Value-> +> > -- Derive boilerplate code using Template Haskell (GHC 7 needed)-> $(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] +> $(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] >          [''Value, ''Op])-> +> > -- Term evaluation algebra > class Eval f v where >   evalAlg :: Alg f (Term v)-> +> > instance (Eval f v, Eval g v) => Eval (f :+: g) v where >   evalAlg (Inl x) = evalAlg x >   evalAlg (Inr x) = evalAlg x-> +> > -- Lift the evaluation algebra to a catamorphism > eval :: (HFunctor f, Eval f v) => Term f :-> Term v > eval = cata evalAlg-> +> > instance (Value :<: v) => Eval Value v where >   evalAlg = inject-> +> > instance (Value :<: v) => Eval Op v where >   evalAlg (Add x y)  = iConst $ (projC x) + (projC y) >   evalAlg (Mult x y) = iConst $ (projC x) * (projC y) >   evalAlg (Fst x)    = fst $ projP x >   evalAlg (Snd x)    = snd $ projP x-> +> > projC :: (Value :<: v) => Term v Int -> Int > projC v = case project v of Just (Const n) -> n-> +> > projP :: (Value :<: v) => Term v (s,t) -> (Term v s, Term v t) > projP v = case project v of Just (Pair x y) -> (x,y)-> +> > -- Example: evalEx = iConst 2 > evalEx :: Term Value Int > evalEx = eval (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int)@@ -96,7 +96,7 @@  {- $ex2 The example illustrates how to use generalised compositional data types to-implement a small expression language, with a sub language of values, and a +implement a small expression language, with a sub language of values, and a monadic evaluation function mapping expressions to values.  The following language extensions are needed in order to run the example:@@ -108,7 +108,7 @@ > import Data.Comp.Multi.Show () > import Data.Comp.Multi.Derive > import Control.Monad (liftM)-> +> > -- Signature for values and operators > data Value e l where >   Const  ::        Int -> Value e Int@@ -117,29 +117,29 @@ >   Add, Mult  :: e Int -> e Int   -> Op e Int >   Fst        ::          e (s,t) -> Op e s >   Snd        ::          e (s,t) -> Op e t-> +> > -- Signature for the simple expression language > type Sig = Op :+: Value-> +> > -- Derive boilerplate code using Template Haskell (GHC 7 needed) > $(derive [makeHFunctor, makeHTraversable, makeHFoldable, >           makeHEqF, makeHShowF, smartConstructors] >          [''Value, ''Op])-> +> > -- Monadic term evaluation algebra > class EvalM f v where >   evalAlgM :: AlgM Maybe f (Term v)-> +> > instance (EvalM f v, EvalM g v) => EvalM (f :+: g) v where >   evalAlgM (Inl x) = evalAlgM x >   evalAlgM (Inr x) = evalAlgM x-> +> > evalM :: (HTraversable f, EvalM f v) => Term f l -> Maybe (Term v l) > evalM = cataM evalAlgM-> +> > instance (Value :<: v) => EvalM Value v where >   evalAlgM = return . inject-> +> > instance (Value :<: v) => EvalM Op v where >   evalAlgM (Add x y)  = do n1 <- projC x >                            n2 <- projC y@@ -149,15 +149,15 @@ >                            return $ iConst $ n1 * n2 >   evalAlgM (Fst v)    = liftM fst $ projP v >   evalAlgM (Snd v)    = liftM snd $ projP v-> +> > projC :: (Value :<: v) => Term v Int -> Maybe Int > projC v = case project v of >             Just (Const n) -> return n; _ -> Nothing-> +> > projP :: (Value :<: v) => Term v (a,b) -> Maybe (Term v a, Term v b) > projP v = case project v of >             Just (Pair x y) -> return (x,y); _ -> Nothing-> +> > -- Example: evalMEx = Just (iConst 5) > evalMEx :: Maybe (Term Value Int) > evalMEx = evalM ((iConst 1) `iAdd`@@ -165,7 +165,7 @@ -}  {- $ex3-The example illustrates how to use generalised compositional data types +The example illustrates how to use generalised compositional data types to implement a small expression language, and  an evaluation function mapping intrinsically typed expressions to values. @@ -177,7 +177,7 @@ > import Data.Comp.Multi > import Data.Comp.Multi.Show () > import Data.Comp.Multi.Derive-> +> > -- Signature for values and operators > data Value e l where >   Const  ::        Int -> Value e Int@@ -186,36 +186,36 @@ >   Add, Mult  :: e Int -> e Int   -> Op e Int >   Fst        ::          e (s,t) -> Op e s >   Snd        ::          e (s,t) -> Op e t-> +> > -- Signature for the simple expression language > type Sig = Op :+: Value-> +> > -- Derive boilerplate code using Template Haskell (GHC 7 needed)-> $(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] +> $(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] >          [''Value, ''Op])-> +> > -- Term evaluation algebra > class EvalI f where >   evalAlgI :: Alg f I-> +> > instance (EvalI f, EvalI g) => EvalI (f :+: g) where >   evalAlgI (Inl x) = evalAlgI x >   evalAlgI (Inr x) = evalAlgI x-> +> > -- Lift the evaluation algebra to a catamorphism > evalI :: (HFunctor f, EvalI f) => Term f i -> i > evalI = unI . cata evalAlgI-> +> > instance EvalI Value where >   evalAlgI (Const n) = I n >   evalAlgI (Pair (I x) (I y)) = I (x,y)-> +> > instance EvalI Op where >   evalAlgI (Add (I x) (I y))  = I (x + y) >   evalAlgI (Mult (I x) (I y)) = I (x * y) >   evalAlgI (Fst (I (x,_)))    = I x >   evalAlgI (Snd (I (_,y)))    = I y-> +> > -- Example: evalEx = 2 > evalIEx :: Int > evalIEx = evalI (iFst $ iPair (iConst 2) (iConst 1) :: Term Sig Int)@@ -233,7 +233,7 @@ > import Data.Comp.Multi > import Data.Comp.Multi.Show () > import Data.Comp.Multi.Derive-> +> > -- Signature for values, operators, and syntactic sugar > data Value e l where >   Const  ::        Int -> Value e Int@@ -245,75 +245,75 @@ > data Sugar e l where >   Neg   :: e Int   -> Sugar e Int >   Swap  :: e (s,t) -> Sugar e (t,s)-> +> > -- Source position information (line number, column number) > data Pos = Pos Int Int >            deriving Show-> +> > -- Signature for the simple expression language > type Sig = Op :+: Value > type SigP = Op :&: Pos :+: Value :&: Pos-> +> > -- Signature for the simple expression language, extended with syntactic sugar > type Sig' = Sugar :+: Op :+: Value > type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos-> +> > -- Derive boilerplate code using Template Haskell (GHC 7 needed) > $(derive [makeHFunctor, makeHTraversable, makeHFoldable, >           makeHEqF, makeHShowF, smartConstructors] >          [''Value, ''Op, ''Sugar])-> +> > -- Term homomorphism for desugaring of terms > class (HFunctor f, HFunctor g) => Desugar f g where >   desugHom :: Hom f g >   desugHom = desugHom' . hfmap Hole >   desugHom' :: Alg f (Context g a) >   desugHom' x = appCxt (desugHom x)-> +> > instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where >   desugHom (Inl x) = desugHom x >   desugHom (Inr x) = desugHom x >   desugHom' (Inl x) = desugHom' x >   desugHom' (Inr x) = desugHom' x-> +> > instance (Value :<: v, HFunctor v) => Desugar Value v where >   desugHom = simpCxt . inj-> +> > instance (Op :<: v, HFunctor v) => Desugar Op v where >   desugHom = simpCxt . inj-> +> > instance (Op :<: v, Value :<: v, HFunctor v) => Desugar Sugar v where >   desugHom' (Neg x)  = iConst (-1) `iMult` x >   desugHom' (Swap x) = iSnd x `iPair` iFst x-> +> > -- Term evaluation algebra > class Eval f v where >   evalAlg :: Alg f (Term v)-> +> > instance (Eval f v, Eval g v) => Eval (f :+: g) v where >   evalAlg (Inl x) = evalAlg x >   evalAlg (Inr x) = evalAlg x-> +> > instance (Value :<: v) => Eval Value v where >   evalAlg = inject-> +> > instance (Value :<: v) => Eval Op v where >   evalAlg (Add x y)  = iConst $ (projC x) + (projC y) >   evalAlg (Mult x y) = iConst $ (projC x) * (projC y) >   evalAlg (Fst x)    = fst $ projP x >   evalAlg (Snd x)    = snd $ projP x-> +> > projC :: (Value :<: v) => Term v Int -> Int > projC v = case project v of Just (Const n) -> n-> +> > projP :: (Value :<: v) => Term v (s,t) -> (Term v s, Term v t) > projP v = case project v of Just (Pair x y) -> (x,y)-> +> > -- Compose the evaluation algebra and the desugaring homomorphism to an > -- algebra > eval :: Term Sig' :-> Term Value > eval = cata (evalAlg `compAlg` (desugHom :: Hom Sig' Sig))-> +> > -- Example: evalEx = iPair (iConst 2) (iConst 1) > evalEx :: Term Value (Int,Int) > evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)@@ -332,7 +332,7 @@ > import Data.Comp.Multi > import Data.Comp.Multi.Show () > import Data.Comp.Multi.Derive-> +> > -- Signature for values, operators, and syntactic sugar > data Value e l where >   Const  ::        Int -> Value e Int@@ -344,74 +344,74 @@ > data Sugar e l where >   Neg   :: e Int   -> Sugar e Int >   Swap  :: e (s,t) -> Sugar e (t,s)-> +> > -- Source position information (line number, column number) > data Pos = Pos Int Int >            deriving (Show, Eq)-> +> > -- Signature for the simple expression language > type Sig = Op :+: Value > type SigP = Op :&: Pos :+: Value :&: Pos-> +> > -- Signature for the simple expression language, extended with syntactic sugar > type Sig' = Sugar :+: Op :+: Value > type SigP' = Sugar :&: Pos :+: Op :&: Pos :+: Value :&: Pos-> +> > -- Derive boilerplate code using Template Haskell (GHC 7 needed) > $(derive [makeHFunctor, makeHTraversable, makeHFoldable, >           makeHEqF, makeHShowF, smartConstructors] >          [''Value, ''Op, ''Sugar])-> +> > -- Term homomorphism for desugaring of terms > class (HFunctor f, HFunctor g) => Desugar f g where >   desugHom :: Hom f g >   desugHom = desugHom' . hfmap Hole >   desugHom' :: Alg f (Context g a) >   desugHom' x = appCxt (desugHom x)-> +> > instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where >   desugHom (Inl x) = desugHom x >   desugHom (Inr x) = desugHom x >   desugHom' (Inl x) = desugHom' x >   desugHom' (Inr x) = desugHom' x-> +> > instance (Value :<: v, HFunctor v) => Desugar Value v where >   desugHom = simpCxt . inj-> +> > instance (Op :<: v, HFunctor v) => Desugar Op v where >   desugHom = simpCxt . inj-> +> > instance (Op :<: v, Value :<: v, HFunctor v) => Desugar Sugar v where >   desugHom' (Neg x)  = iConst (-1) `iMult` x >   desugHom' (Swap x) = iSnd x `iPair` iFst x-> +> > -- Lift the desugaring term homomorphism to a catamorphism > desug :: Term Sig' :-> Term Sig > desug = appHom desugHom-> +> > -- Example: desugEx = iPair (iConst 2) (iConst 1) > desugEx :: Term Sig (Int,Int) > desugEx = desug $ iSwap $ iPair (iConst 1) (iConst 2)-> +> > -- Lift desugaring to terms annotated with source positions > desugP :: Term SigP' :-> Term SigP > desugP = appHom (propAnn desugHom)-> +> > iSwapP :: (DistAnn f p f', Sugar :<: f) => p -> Term f' (a,b) -> Term f' (b,a) > iSwapP p x = Term (injectA p $ inj $ Swap x)-> +> > iConstP :: (DistAnn f p f', Value :<: f) => p -> Int -> Term f' Int > iConstP p x = Term (injectA p $ inj $ Const x)-> +> > iPairP :: (DistAnn f p f', Value :<: f) => p -> Term f' a -> Term f' b -> Term f' (a,b) > iPairP p x y = Term (injectA p $ inj $ Pair x y)-> +> > iFstP :: (DistAnn f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' a > iFstP p x = Term (injectA p $ inj $ Fst x)-> +> > iSndP :: (DistAnn f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' b > iSndP p x = Term (injectA p $ inj $ Snd x)-> +> > -- Example: desugPEx = iPairP (Pos 1 0) > --                            (iSndP (Pos 1 0) (iPairP (Pos 1 1) > --                                                     (iConstP (Pos 1 2) 1)
src/Data/Comp/Multi/Algebra.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE GADTs, Rank2Types, TypeOperators, ScopedTypeVariables, -  FlexibleContexts, KindSignatures #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Algebra@@ -22,7 +26,7 @@       cata,       cata',       appCxt,-      +       -- * Monadic Algebras & Catamorphisms       AlgM,       freeM,@@ -86,11 +90,13 @@     ) where  -import Data.Comp.Multi.Term+import Control.Monad+import Data.Kind+ import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable+import Data.Comp.Multi.Term import Data.Comp.Ops-import Control.Monad  -- | This type represents multisorted @f@-algebras with a family @e@ -- of carriers.@@ -107,7 +113,7 @@  -- | Construct a catamorphism from the given algebra. cata :: forall f a. HFunctor f => Alg f a -> Term f :-> a-cata f = run +cata f = run     where run :: Term f :-> a           run (Term t) = f (hfmap run t) @@ -160,7 +166,7 @@   -- | This type represents uniform signature function specification.-type SigFun f g = forall (a :: * -> *). f a :-> g a+type SigFun f g = forall (a :: Type -> Type). f a :-> g a  -- | This type represents context function. type CxtFun f g = forall h . SigFun (Cxt h f) (Cxt h g)@@ -225,7 +231,7 @@ hom f = simpCxt . f  -- | This type represents monadic signature functions.-type SigFunM m f g = forall (a :: * -> *) . NatM m (f a) (g a)+type SigFunM m f g = forall (a :: Type -> Type) . NatM m (f a) (g a)   -- | This type represents monadic context function.@@ -342,7 +348,7 @@  anaM :: forall a m f. (HTraversable f, Monad m)           => CoalgM m f a -> NatM m a (Term f)-anaM f = run +anaM f = run     where run :: NatM m a (Term f)           run t = liftM Term $ f t >>= hmapM run @@ -367,7 +373,7 @@  -- | This function constructs a monadic paramorphism from the given -- monadic r-algebra-paraM :: forall f m a. (HTraversable f, Monad m) => +paraM :: forall f m a. (HTraversable f, Monad m) =>          RAlgM m f a -> NatM m(Term f)  a paraM f = liftM fsnd . cataM run     where run :: AlgM m f (Term f :*: a)@@ -386,7 +392,7 @@ -- | This function constructs an apomorphism from the given -- r-coalgebra. apo :: forall f a . (HFunctor f) => RCoalg f a -> a :-> Term f-apo f = run +apo f = run     where run :: a :-> Term f           run = Term . hfmap run' . f           run' :: Term f :+: a :-> Term f@@ -402,7 +408,7 @@ -- monadic r-coalgebra. apoM :: forall f m a . (HTraversable f, Monad m) =>         RCoalgM m f a -> NatM m a (Term f)-apoM f = run +apoM f = run     where run :: NatM m a (Term f)           run a = do             t <- f a
src/Data/Comp/Multi/Annotation.hs view
@@ -1,5 +1,12 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses,-  FlexibleInstances, UndecidableInstances, Rank2Types, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Annotation@@ -27,14 +34,11 @@      project'     ) where -import Data.Comp.Multi.Term-import Data.Comp.Multi.Sum-import Data.Comp.Multi.Ops-import qualified Data.Comp.Ops as O import Data.Comp.Multi.Algebra import Data.Comp.Multi.HFunctor--import Control.Monad+import Data.Comp.Multi.Ops+import Data.Comp.Multi.Term+import qualified Data.Comp.Ops as O  -- | This function transforms a function with a domain constructed -- from a functor to a function with a domain constructed with the@@ -56,7 +60,7 @@        => (s' a :-> Cxt h s' a) -> s a :-> Cxt h s a liftA' f v = let (v' O.:&: p) = projectA v              in ann p (f v')-    + {-| This function strips the annotations from a term over a functor with annotations. -} @@ -64,12 +68,13 @@ stripA = appSigFun remA  -propAnn :: (DistAnn f p f', DistAnn g p g', HFunctor g) +propAnn :: (DistAnn f p f', DistAnn g p g', HFunctor g)                => Hom f g -> Hom f' g' propAnn alg f' = ann p (alg f)     where (f O.:&: p) = projectA f'  -- | This function is similar to 'project' but applies to signatures -- with an annotation which is then ignored.-project' :: forall s s' f h a i . (RemA s s', s :<: f) => Cxt h f a i -> Maybe (s' (Cxt h f a) i)-project' v = liftM remA (project v :: Maybe (s (Cxt h f a) i))+project' :: (RemA f f', s :<: f') => Cxt h f a i -> Maybe (s (Cxt h f a) i)+project' (Term x) = proj $ remA x+project' _ = Nothing
src/Data/Comp/Multi/Derive.hs view
@@ -42,13 +42,13 @@  import Data.Comp.Derive.Utils (derive, liftSumGen) import Data.Comp.Multi.Derive.Equality-import Data.Comp.Multi.Derive.Ordering-import Data.Comp.Multi.Derive.Show-import Data.Comp.Multi.Derive.HFunctor import Data.Comp.Multi.Derive.HFoldable+import Data.Comp.Multi.Derive.HFunctor import Data.Comp.Multi.Derive.HTraversable-import Data.Comp.Multi.Derive.SmartConstructors+import Data.Comp.Multi.Derive.Ordering+import Data.Comp.Multi.Derive.Show import Data.Comp.Multi.Derive.SmartAConstructors+import Data.Comp.Multi.Derive.SmartConstructors import Data.Comp.Multi.Ops ((:+:), caseH)  import Language.Haskell.TH
src/Data/Comp/Multi/Derive/Equality.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell   #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Derive.Equality@@ -26,36 +27,35 @@   kind taking at least two arguments. -} makeEqHF :: Name -> Q [Dec] makeEqHF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       argNames = map (VarT . tyVarBndrName) (init args')       ftyp = VarT . tyVarBndrName $ last args'       complType = foldl AppT (ConT name) argNames-      preCond = map (ClassP ''Eq . (: [])) argNames+      preCond = map (mkClassP ''Eq . (: [])) argNames       classType = AppT (ConT ''EqHF) complType   constrs' <- mapM normalConExp constrs   eqFDecl <- funD 'eqHF  (eqFClauses ftyp constrs constrs')-  return [InstanceD preCond classType [eqFDecl]]+  return [mkInstanceD preCond classType [eqFDecl]]       where eqFClauses ftyp constrs constrs' = map (genEqClause ftyp) constrs'                                    ++ defEqClause constrs-            filterFarg fArg ty x = (containsType ty fArg, varE x)             defEqClause constrs                 | length constrs  < 2 = []                 | otherwise = [clause [wildP,wildP] (normalB [|False|]) []]-            genEqClause ftyp (constr, argts) = do +            genEqClause ftyp (constr, argts, gadtTy) = do               let n = length argts               varNs <- newNames n "x"               varNs' <- newNames n "y"-              let pat = ConP constr $ map VarP varNs-                  pat' = ConP constr $ map VarP varNs'+              let pat = ConP constr [] $ map VarP varNs+                  pat' = ConP constr [] $ map VarP varNs'                   vars = map VarE varNs                   vars' = map VarE varNs'                   mkEq ty x y = let (x',y') = (return x,return y)-                                in if containsType ty ftyp+                                in if containsType ty (getBinaryFArg ftyp gadtTy)                                    then [| $x' `keq` $y'|]                                    else [| $x' == $y'|]                   eqs = listE $ zipWith3 mkEq argts vars vars'-              body <- if n == 0 +              body <- if n == 0                       then [|True|]                       else [|and $eqs|]               return $ Clause [pat, pat'] (NormalB body) []
src/Data/Comp/Multi/Derive/HFoldable.hs view
@@ -18,25 +18,24 @@      makeHFoldable     )where +import Control.Monad import Data.Comp.Derive.Utils-import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HFoldable+import Data.Comp.Multi.HFunctor import Data.Foldable-import Language.Haskell.TH-import Data.Monoid import Data.Maybe-import qualified Prelude as P (foldl,foldr,foldl1)-import Prelude hiding  (foldl,foldr,foldl1)-import Control.Monad+import Data.Monoid+import Language.Haskell.TH+import Prelude hiding (foldl, foldl1, foldr)+import qualified Prelude as P (foldl, foldl1, foldr)   iter 0 _ e = e iter n f e = iter (n-1) f (f `appE` e) -iter' n f e = run n f e-    where run 0 _ e = e-          run m f e = let f' = iter (m-1) [|fmap|] f-                      in run (m-1) f (f' `appE` e)+iter' 0 _ e = e+iter' m f e = let f' = iter (m-1) [|fmap|] f+              in iter' (m-1) f (f' `appE` e)  iterSp n f g e = run n e     where run 0 e = e@@ -47,7 +46,7 @@   kind taking at least two arguments. -} makeHFoldable :: Name -> Q [Dec] makeHFoldable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')@@ -58,13 +57,13 @@   foldMapDecl <- funD 'hfoldMap (map foldMapClause constrs')   foldlDecl <- funD 'hfoldl (map foldlClause constrs')   foldrDecl <- funD 'hfoldr (map foldrClause constrs')-  return [InstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [foldDecl,foldMapDecl,foldlDecl,foldrDecl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getBinaryFArg fArg gadtTy)) args)             filterVar [] _ = Nothing             filterVar [d] x =Just (d, varE x)             filterVar _ _ =  error "functor variable occurring twice in argument type"             filterVars args varNs = catMaybes $ zipWith filterVar args varNs-            mkCPat constr args varNs = ConP constr $ zipWith mkPat args varNs+            mkCPat constr args varNs = ConP constr [] $ zipWith mkPat args varNs             mkPat [] _ = WildP             mkPat _ x = VarP x             mkPatAndVars (constr, args) =@@ -86,7 +85,7 @@                        fp = if null vars then WildP else VarP fn                    body <- case vars of                              [] -> [|mempty|]-                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $ +                             (_:_) -> P.foldl1 (\ x y -> [|$x `mappend` $y|]) $                                       map (\ (d,z) -> iter' (max (d-1) 0) [|fold|] (f' d `appE` z)) vars                    return $ Clause [fp, pat] (NormalB body) []             foldlClause (pat,vars) =
src/Data/Comp/Multi/Derive/HFunctor.hs view
@@ -18,13 +18,13 @@      makeHFunctor     ) where +import Control.Monad import Data.Comp.Derive.Utils import Data.Comp.Multi.HFunctor+import Data.Maybe import Language.Haskell.TH-import qualified Prelude as P (mapM) import Prelude hiding (mapM)-import Data.Maybe-import Control.Monad+import qualified Prelude as P (mapM)  iter 0 _ e = e iter n f e = iter (n-1) f (f `appE` e)@@ -33,7 +33,7 @@   kind taking at least two arguments. -} makeHFunctor :: Name -> Q [Dec] makeHFunctor fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')@@ -41,14 +41,15 @@       classType = AppT (ConT ''HFunctor) complType   constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs   hfmapDecl <- funD 'hfmap (map hfmapClause constrs')-  return [InstanceD [] classType [hfmapDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [hfmapDecl]]+      where isFarg fArg (constr, args, ty) = (constr, map (`containsType'` getBinaryFArg fArg ty) args)             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"             filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs-            mkCPat constr varNs = ConP constr $ map mkPat varNs+            mkCPat constr varNs = ConP constr [] $ map mkPat varNs             mkPat = VarP+            mkPatAndVars :: (Name, [[t]]) -> Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool, [Q Exp], [(t, Name)])             mkPatAndVars (constr, args) =                 do varNs <- newNames (length args) "x"                    return (conE constr, mkCPat constr varNs,
src/Data/Comp/Multi/Derive/HTraversable.hs view
@@ -18,30 +18,26 @@      makeHTraversable     ) where +import Control.Applicative+import Control.Monad hiding (mapM, sequence) import Data.Comp.Derive.Utils import Data.Comp.Multi.HTraversable-import Language.Haskell.TH+import Data.Foldable hiding (any, or) import Data.Maybe import Data.Traversable-import Data.Foldable hiding (any,or)-import Control.Applicative-import Control.Monad hiding (mapM, sequence)+import Language.Haskell.TH+import Prelude hiding (foldl, foldr, mapM, sequence) import qualified Prelude as P (foldl, foldr, mapM)-import Prelude hiding  (foldl, foldr,mapM, sequence)  iter 0 _ e = e iter n f e = iter (n-1) f (f `appE` e) -iter' n f e = run n f e-    where run 0 _ e = e-          run m f e = let f' = iter (m-1) [|fmap|] f-                        in run (m-1) f (f' `appE` e)  {-| Derive an instance of 'HTraversable' for a type constructor of any   higher-order kind taking at least two arguments. -} makeHTraversable :: Name -> Q [Dec] makeHTraversable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')@@ -50,13 +46,13 @@   constrs' <- P.mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs   traverseDecl <- funD 'htraverse (map traverseClause constrs')   mapMDecl <- funD 'hmapM (map mapMClause constrs')-  return [InstanceD [] classType [traverseDecl, mapMDecl]]-      where isFarg fArg (constr, args) = (constr, map (`containsType'` fArg) args)+  return [mkInstanceD [] classType [traverseDecl, mapMDecl]]+      where isFarg fArg (constr, args, gadtTy) = (constr, map (`containsType'` (getBinaryFArg fArg gadtTy)) args)             filterVar _ nonFarg [] x  = nonFarg x             filterVar farg _ [depth] x = farg depth x             filterVar _ _ _ _ = error "functor variable occurring twice in argument type"             filterVars args varNs farg nonFarg = zipWith (filterVar farg nonFarg) args varNs-            mkCPat constr varNs = ConP constr $ map mkPat varNs+            mkCPat constr varNs = ConP constr [] $ map mkPat varNs             mkPat = VarP             mkPatAndVars (constr, args) =                 do varNs <- newNames (length args) "x"
− src/Data/Comp/Multi/Derive/Injections.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Multi.Derive.Injections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature injections.--------------------------------------------------------------------------------------module Data.Comp.Multi.Derive.Injections-    (-     injn,-     injectn,-     deepInjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Multi.HFunctor-import Data.Comp.Multi.Term-import Data.Comp.Multi.Algebra (CxtFun, appSigFun)-import Data.Comp.Multi.Ops ((:+:)(..), (:<:)(..))--injn :: Int -> Q [Dec]-injn n = do-  let i = mkName $ "inj" ++ show n-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let ivar = mkName "i"-  let xvar = mkName "x"-  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ sigD i (genSig fvars gvar avar ivar) : d-    where genSig fvars gvar avar ivar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = arrowT `appT` (tp `appT` varT avar `appT` varT ivar)-                             `appT` (varT gvar `appT` varT avar-                                               `appT` varT ivar)-            forallT (map PlainTV $ gvar : avar : ivar : fvars)-                    (sequence cxt) tp'-          genDecl x n = [| case $(varE x) of-                             Inl x -> $(varE $ mkName "inj") x-                             Inr x -> $(varE $ mkName $ "inj" ++-                                        if n > 2 then show (n - 1) else "") x |]-injectn :: Int -> Q [Dec]-injectn n = do-  let i = mkName ("inject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let ivar = mkName "i"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar avar ivar) : d-    where genSig fvars gvar avar ivar = do-            let hvar = mkName "h"-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar-                                 `appT` varT avar-            let tp'' = arrowT `appT` (tp `appT` tp' `appT` varT ivar)-                              `appT` (tp' `appT` varT ivar)-            forallT (map PlainTV $ hvar : gvar : avar : ivar : fvars)-                    (sequence cxt) tp''-          genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]--deepInjectn :: Int -> Q [Dec]-deepInjectn n = do-  let i = mkName ("deepInject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar) : d-    where genSig fvars gvar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let cxt' = classP ''HFunctor [tp]-            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar-            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
src/Data/Comp/Multi/Derive/Ordering.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,-  ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Derive.Ordering@@ -18,10 +19,10 @@      makeOrdHF     ) where -import Data.Comp.Multi.Ordering import Data.Comp.Derive.Utils-import Data.Maybe+import Data.Comp.Multi.Ordering import Data.List+import Data.Maybe import Language.Haskell.TH hiding (Cxt)  compList :: [Ordering] -> Ordering@@ -31,19 +32,19 @@   kind taking at least three arguments. -} makeOrdHF :: Name -> Q [Dec] makeOrdHF fname = do-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _ name args constrs _) <- abstractNewtypeQ $ reify fname   let args' = init args   -- covariant argument-  let coArg :: Name = tyVarBndrName $ last args'+  let coArg :: Type = VarT $ tyVarBndrName $ last args'   let argNames = map (VarT . tyVarBndrName) (init args')   let complType = foldl AppT (ConT name) argNames   let classType = AppT (ConT ''OrdHF) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+  constrs' :: [(Name,[Type],Maybe Type)] <- mapM normalConExp constrs   compareHFDecl <- funD 'compareHF (compareHFClauses coArg constrs')-  return [InstanceD [] classType [compareHFDecl]]-      where compareHFClauses :: Name -> [(Name,[Type])] -> [ClauseQ]+  return [mkInstanceD [] classType [compareHFDecl]]+      where compareHFClauses :: Type -> [(Name,[Type],Maybe Type)] -> [ClauseQ]             compareHFClauses _ [] = []-            compareHFClauses coArg constrs = +            compareHFClauses coArg constrs =                 let constrs' = constrs `zip` [1..]                     constPairs = [(x,y)| x<-constrs', y <- constrs']                 in map (genClause coArg) constPairs@@ -51,24 +52,24 @@                 | n == m = genEqClause coArg c                 | n < m = genLtClause c d                 | otherwise = genGtClause c d-            genEqClause :: Name -> (Name,[Type]) -> ClauseQ-            genEqClause coArg (constr, args) = do +            genEqClause :: Type -> (Name,[Type],Maybe Type) -> ClauseQ+            genEqClause coArg (constr, args,gadtTy) = do               varXs <- newNames (length args) "x"               varYs <- newNames (length args) "y"-              let patX = ConP constr $ map VarP varXs-              let patY = ConP constr $ map VarP varYs-              body <- eqDBody coArg (zip3 varXs varYs args)+              let patX = ConP constr [] $ map VarP varXs+              let patY = ConP constr [] $ map VarP varYs+              body <- eqDBody (getBinaryFArg coArg gadtTy) (zip3 varXs varYs args)               return $ Clause [patX, patY] (NormalB body) []-            eqDBody :: Name -> [(Name, Name, Type)] -> ExpQ+            eqDBody :: Type -> [(Name, Name, Type)] -> ExpQ             eqDBody coArg x =                 [|compList $(listE $ map (eqDB coArg) x)|]-            eqDB :: Name -> (Name, Name, Type) -> ExpQ+            eqDB :: Type -> (Name, Name, Type) -> ExpQ             eqDB coArg (x, y, tp)-                | not (containsType tp (VarT coArg)) =+                | not (containsType tp coArg) =                     [| compare $(varE x) $(varE y) |]                 | otherwise =                     [| kcompare $(varE x) $(varE y) |]-            genLtClause (c, _) (d, _) =+            genLtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| LT |]) []-            genGtClause (c, _) (d, _) =+            genGtClause (c, _, _) (d, _, _) =                 clause [recP c [], recP d []] (normalB [| GT |]) []
− src/Data/Comp/Multi/Derive/Projections.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE TemplateHaskell, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Multi.Derive.Projections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature projections.--------------------------------------------------------------------------------------module Data.Comp.Multi.Derive.Projections-    (-     projn,-     projectn,-     deepProjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Control.Monad (liftM)-import Data.Comp.Multi.HTraversable (HTraversable)-import Data.Comp.Multi.Term-import Data.Comp.Multi.Algebra (CxtFunM, appSigFunM')-import Data.Comp.Multi.Ops ((:+:)(..), (:<:)(..))--projn :: Int -> Q [Dec]-projn n = do-  let p = mkName $ "proj" ++ show n-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let ivar = mkName "i"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar ivar) []]]-  sequence $ (sigD p $ genSig gvars avar ivar) : d-    where genSig gvars avar ivar = do-            let fvar = mkName "f"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = arrowT-                      `appT` (varT fvar `appT` varT avar `appT` varT ivar)-                      `appT` (conT ''Maybe `appT`-                              (tp `appT` varT avar `appT` varT ivar))-            forallT (map PlainTV $ fvar : ivar : avar : gvars)-                    (sequence cxt) tp'-          genDecl x [g] a i =-            [| liftM inj (proj $(varE x)-                          :: Maybe ($(varT g `appT` varT a `appT` varT i))) |]-          genDecl x (g:gs) a i =-            [| case (proj $(varE x)-                         :: Maybe ($(varT g `appT` varT a `appT` varT i))) of-                 Just y -> Just $ inj y-                 _ -> $(genDecl x gs a i) |]-          genDecl _ _ _ _ = error "genDecl called with empty list"--projectn :: Int -> Q [Dec]-projectn n = do-  let p = mkName ("project" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let ivar = mkName "i"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ (sigD p $ genSig gvars avar ivar) : d-    where genSig gvars avar ivar = do-            let fvar = mkName "f"-            let hvar = mkName "h"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar-                                 `appT` varT avar-            let tp'' = arrowT `appT` (tp' `appT` varT ivar)-                              `appT` (conT ''Maybe `appT`-                                      (tp `appT` tp' `appT` varT ivar))-            forallT (map PlainTV $ hvar : fvar : avar : ivar : gvars)-                    (sequence cxt) tp''-          genDecl x n = [| case $(varE x) of-                             Hole _ -> Nothing-                             Term t -> $(varE $ mkName $ "proj" ++ show n) t |]--deepProjectn :: Int -> Q [Dec]-deepProjectn n = do-  let p = mkName ("deepProject" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let d = [funD p [clause [] (normalB $ genDecl n) []]]-  sequence $ (sigD p $ genSig gvars) : d-    where genSig gvars = do-            let fvar = mkName "f"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let cxt' = classP ''HTraversable [tp]-            let tp' = conT ''CxtFunM `appT` conT ''Maybe-                                     `appT` varT fvar `appT` tp-            forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
src/Data/Comp/Multi/Derive/Show.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TemplateHaskell, TypeOperators #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators   #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Derive.Show@@ -20,8 +21,8 @@     ) where  import Data.Comp.Derive.Utils-import Data.Comp.Multi.HFunctor import Data.Comp.Multi.Algebra+import Data.Comp.Multi.HFunctor import Language.Haskell.TH  {-| Signature printing. An instance @ShowHF f@ gives rise to an instance@@ -43,26 +44,26 @@   kind taking at least two arguments. -} makeShowHF :: Name -> Q [Dec] makeShowHF fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname   let args' = init args       fArg = VarT . tyVarBndrName $ last args'       argNames = map (VarT . tyVarBndrName) (init args')       complType = foldl AppT (ConT name) argNames-      preCond = map (ClassP ''Show . (: [])) argNames+      preCond = map (mkClassP ''Show . (: [])) argNames       classType = AppT (ConT ''ShowHF) complType   constrs' <- mapM normalConExp constrs   showFDecl <- funD 'showHF (showFClauses fArg constrs')-  return [InstanceD preCond classType [showFDecl]]+  return [mkInstanceD preCond classType [showFDecl]]       where showFClauses fArg = map (genShowFClause fArg)             filterFarg fArg ty x = (containsType ty fArg, varE x)             mkShow (isFArg, var)                 | isFArg = [|unK $var|]                 | otherwise = [| show $var |]-            genShowFClause fArg (constr, args) = do +            genShowFClause fArg (constr, args, ty) = do               let n = length args               varNs <- newNames n "x"-              let pat = ConP constr $ map VarP varNs-                  allVars = zipWith (filterFarg fArg) args varNs+              let pat = ConP constr [] $ map VarP varNs+                  allVars = zipWith (filterFarg (getBinaryFArg fArg ty)) args varNs                   shows = listE $ map mkShow allVars                   conName = nameBase constr               body <- [|K $ showConstr conName $shows|]
src/Data/Comp/Multi/Derive/SmartAConstructors.hs view
@@ -12,17 +12,17 @@ -- -------------------------------------------------------------------------------- -module Data.Comp.Multi.Derive.SmartAConstructors +module Data.Comp.Multi.Derive.SmartAConstructors     (      smartAConstructors     ) where -import Language.Haskell.TH hiding (Cxt)+import Control.Monad import Data.Comp.Derive.Utils+import Data.Comp.Multi.Annotation import Data.Comp.Multi.Sum import Data.Comp.Multi.Term-import Data.Comp.Multi.Annotation-import Control.Monad+import Language.Haskell.TH hiding (Cxt)  {-| Derive smart constructors with products for a type constructor of any   parametric kind taking at least two arguments. The smart constructors are@@ -30,13 +30,13 @@   inserted. -} smartAConstructors :: Name -> Q [Dec] smartAConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt _tname _targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let cons = map abstractConType constrs-    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons-        where genSmartConstr targs tname (name, args) = do+    liftM concat $ mapM genSmartConstr cons+        where genSmartConstr (name, args) = do                 let bname = nameBase name-                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args-              genSmartConstr' targs tname sname name args = do+                genSmartConstr' (mkName $ "iA" ++ bname) name args+              genSmartConstr' sname name args = do                 varNs <- newNames args "x"                 varPr <- newName "_p"                 let pats = map varP (varPr : varNs)
src/Data/Comp/Multi/Derive/SmartConstructors.hs view
@@ -12,30 +12,30 @@ -- -------------------------------------------------------------------------------- -module Data.Comp.Multi.Derive.SmartConstructors +module Data.Comp.Multi.Derive.SmartConstructors     (      smartConstructors     ) where -import Language.Haskell.TH hiding (Cxt)+import Control.Arrow ((&&&))+import Control.Monad import Data.Comp.Derive.Utils import Data.Comp.Multi.Sum import Data.Comp.Multi.Term-import Control.Arrow ((&&&))-import Control.Monad+import Language.Haskell.TH hiding (Cxt)  {-| Derive smart constructors for a type constructor of any higher-order kind  taking at least two arguments. The smart constructors are similar to the  ordinary constructors, but an 'inject' is automatically inserted. -} smartConstructors :: Name -> Q [Dec] smartConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname+    Just (DataInfo _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname     let iVar = tyVarBndrName $ last targs     let cons = map (abstractConType &&& iTp iVar) constrs     liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons         where iTp iVar (ForallC _ cxt _) =                   -- Check if the GADT phantom type is constrained-                  case [y | EqualP x y <- cxt, x == VarT iVar] of+                  case [y | Just (x, y) <- map isEqualP cxt, x == VarT iVar] of                     [] -> Nothing                     tp:_ -> Just tp               iTp _ _ = Nothing@@ -62,8 +62,8 @@                     a = varT avar                     i = varT ivar                     ftype = foldl appT (conT tname) (map varT targs')-                    constr = classP ''(:<:) [ftype, f]+                    constr = (conT ''(:<:) `appT` ftype) `appT` f                     typ = foldl appT (conT ''Cxt) [h, f, a, maybe i return miTp]-                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ+                    typeSig = forallT (map (\ v -> PlainTV v SpecifiedSpec) vars) (sequence [constr]) typ                 sigD sname typeSig               genSig _ _ _ _ _ = []
src/Data/Comp/Multi/Desugar.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,-  UndecidableInstances, TypeOperators, OverlappingInstances #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Desugar@@ -28,7 +31,7 @@  -- We make the lifting to sums explicit in order to make the Desugar -- class work with the default instance declaration further below.-instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where+instance {-# OVERLAPPABLE #-} (Desugar f h, Desugar g h) => Desugar (f :+: g) h where     desugHom = caseH desugHom desugHom  -- |Desugar a term.@@ -41,5 +44,5 @@ desugarA = appHom (propAnn desugHom)  -- |Default desugaring instance.-instance (HFunctor f, HFunctor g, f :<: g) => Desugar f g where+instance {-# OVERLAPPABLE #-} (HFunctor f, HFunctor g, f :<: g) => Desugar f g where     desugHom = simpCxt . inj
src/Data/Comp/Multi/Equality.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE TypeOperators, GADTs, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeOperators     #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Equality@@ -20,11 +22,10 @@      heqMod     ) where -import Data.Comp.Multi.Term-import Data.Comp.Multi.Sum-import Data.Comp.Multi.Ops-import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HFoldable+import Data.Comp.Multi.HFunctor+import Data.Comp.Multi.Ops+import Data.Comp.Multi.Term  class KEq f where     keq :: f i -> f j -> Bool
src/Data/Comp/Multi/Generic.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE GADTs, ExistentialQuantification, TypeOperators, ScopedTypeVariables, Rank2Types #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeOperators             #-}  -------------------------------------------------------------------------------- -- |@@ -17,13 +23,13 @@  module Data.Comp.Multi.Generic where -import Data.Comp.Multi.Term-import Data.Comp.Multi.Sum-import Data.Comp.Multi.HFunctor+import Control.Monad import Data.Comp.Multi.HFoldable+import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Term import GHC.Exts-import Control.Monad import Prelude  import Data.Maybe@@ -32,14 +38,14 @@ -- term. This function is similar to Uniplate's @universe@ function. subterms :: forall f  . HFoldable f => Term f  :=> [E (Term f)] subterms t = build (f t)-    where f :: Term f :=> (E (Term f) -> b -> b) -> b -> b+    where f :: forall i b. Term f i -> (E (Term f) -> b -> b) -> b -> b           f t cons nil = E t `cons` hfoldl (\u s -> f s cons u) nil (unTerm t)  -- | This function returns a list of all subterms of the given term -- that are constructed from a particular functor. subterms' :: forall f g . (HFoldable f, g :<: f) => Term f :=> [E (g (Term f))] subterms' (Term t) = build (f t)-    where f :: f (Term f) :=> (E (g (Term f)) -> b -> b) -> b -> b+    where f :: forall i b. f (Term f) i -> (E (g (Term f)) -> b -> b) -> b -> b           f t cons nil = let rest = hfoldl (\u (Term s) -> f s cons u) nil t                          in case proj t of                               Just t' -> E t' `cons` rest@@ -57,12 +63,12 @@ -- | Monadic version of 'transform'. transformM :: forall f m . (HTraversable f, Monad m) =>              NatM m (Term f) (Term f) -> NatM m (Term f) (Term f)-transformM  f = run +transformM  f = run     where run :: NatM m (Term f) (Term f)           run t = f =<< liftM Term (hmapM run $ unTerm t)  query :: HFoldable f => (Term f :=>  r) -> (r -> r -> r) -> Term f :=> r--- query q c = run +-- query q c = run --     where run i@(Term t) = foldl (\s x -> s `c` run x) (q i) t query q c i@(Term t) = hfoldl (\s x -> s `c` query q c x) (q i) t
src/Data/Comp/Multi/HFoldable.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE RankNTypes, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}  -------------------------------------------------------------------------------- -- |@@ -21,9 +27,9 @@      htoList      ) where -import Data.Monoid-import Data.Maybe import Data.Comp.Multi.HFunctor+import Data.Maybe+import Data.Monoid  -- | Higher-order functors that can be folded. --@@ -35,7 +41,7 @@     hfoldMap :: Monoid m => (a :=> m) -> h a :=> m     hfoldMap f = hfoldr (mappend . f) mempty -    hfoldr :: (a :=> b -> b) -> b -> h a :=> b+    hfoldr :: (a :=> (b->b) ) -> b -> h a :=> b     hfoldr f z t = appEndo (hfoldMap (Endo . f) t) z      hfoldl :: (b -> a :=> b) -> b -> h a :=> b@@ -45,7 +51,7 @@     hfoldr1 :: forall a. (a -> a -> a) -> h (K a) :=> a     hfoldr1 f xs = fromMaybe (error "hfoldr1: empty structure")                    (hfoldr mf Nothing xs)-          where mf :: K a :=> Maybe a -> Maybe a+          where mf :: K a :=> (Maybe a -> Maybe a)                 mf (K x) Nothing = Just x                 mf (K x) (Just y) = Just (f x y) @@ -58,7 +64,7 @@  htoList :: (HFoldable f) => f a :=> [E a] htoList = hfoldr (\ n l ->  E n : l) []-    + kfoldr :: (HFoldable f) => (a -> b -> b) -> b -> f (K a) :=> b kfoldr f = hfoldr (\ (K x) y -> f x y)
src/Data/Comp/Multi/HFunctor.hs view
@@ -1,4 +1,15 @@-{-# LANGUAGE Rank2Types, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DeriveTraversable         #-}+{-# LANGUAGE DeriveFoldable            #-}+{-# LANGUAGE DeriveFunctor             #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE Rank2Types                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE IncoherentInstances       #-}  -------------------------------------------------------------------------------- -- |@@ -28,14 +39,15 @@      (:.:)(..)      ) where +import Data.Functor.Compose+import Data.Kind+ -- | The identity Functor.-newtype I a = I {unI :: a}+newtype I a = I {unI :: a} deriving (Functor, Foldable, Traversable) --- | The parametrised constant functor.-newtype K a i = K {unK :: a} -instance Functor (K a) where-    fmap _ (K x) = K x+-- | The parametrised constant functor.+newtype K a i = K {unK :: a} deriving (Functor, Foldable, Traversable)  data E f = forall i. E {unE :: f i} @@ -78,7 +90,7 @@     -- functor @f g@.     --     -- @ffmap :: (Functor g) => (a -> b) -> f g a -> f g b@-    -- +    --     -- We omit this, as it does not work for GADTs (see Johand and     -- Ghani 2008). @@ -86,7 +98,9 @@     -- @g :-> h@ to a natural transformation @f g :-> f h@     hfmap :: (f :-> g) -> h f :-> h g +instance (Functor f) => HFunctor (Compose f) where hfmap f (Compose xs) = Compose (fmap f xs)+ infixl 5 :.:  -- | This data type denotes the composition of two functor families.-data (f :.: g) e t = Comp f (g e) t+data (:.:) f (g :: (Type -> Type) -> (Type -> Type)) (e :: Type -> Type) t = Comp (f (g e) t)
src/Data/Comp/Multi/HTraversable.hs view
@@ -1,4 +1,10 @@-{-# LANGUAGE Rank2Types, TypeOperators, FlexibleInstances, ScopedTypeVariables, GADTs, MultiParamTypeClasses, UndecidableInstances, IncoherentInstances #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}  -------------------------------------------------------------------------------- -- |@@ -18,9 +24,9 @@      HTraversable (..)     ) where -import Data.Comp.Multi.HFunctor+ import Data.Comp.Multi.HFoldable-import Control.Applicative+import Data.Comp.Multi.HFunctor  class HFoldable t => HTraversable t where @@ -30,7 +36,10 @@     -- Alternative type in terms of natural transformations using     -- functor composition @:.:@:     ---    -- @hmapM :: Monad m => (a :-> m :.: b) -> t a :-> m :.: (t b)@+    -- @+    -- hmapM :: Monad m => (a :-> m :.: b) -> t a :-> m :.: (t b)+    -- @+    --      hmapM :: (Monad m) => NatM m a b -> NatM m (t a) (t b)      htraverse :: (Applicative f) => NatM f a b -> NatM f (t a) (t b)
+ src/Data/Comp/Multi/Mapping.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Mapping+-- Copyright   :  (c) 2014 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides functionality to construct mappings from+-- positions in a functorial value.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Mapping+    ( Numbered (..)+    , unNumbered+    , number+    , HTraversable ()+    , Mapping (..)+    , lookupNumMap) where++import Data.Comp.Multi.HFunctor+import Data.Comp.Multi.HTraversable++import Data.Kind++import Control.Monad.State++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+++-- | This type is used for numbering components of a functorial value.+data Numbered a i = Numbered Int (a i)++unNumbered :: Numbered a :-> a+unNumbered (Numbered _ x) = x+++-- | This function numbers the components of the given functorial+-- value with consecutive integers starting at 0.+number :: HTraversable f => f a :-> f (Numbered a)+number x = evalState (hmapM run x) 0 where+  run b = do n <- get+             put (n+1)+             return $ Numbered n b++++infix 1 |->+infixr 0 &+++class Mapping m (k :: Type -> Type) | m -> k where+    -- | left-biased union of two mappings.+    (&) :: m v -> m v -> m v++    -- | This operator constructs a singleton mapping.+    (|->) :: k i -> v -> m v++    -- | This is the empty mapping.+    empty :: m v++    -- | This function constructs the pointwise product of two maps each+    -- with a default value.+    prodMap :: v1 -> v2 -> m v1 -> m v2 -> m (v1, v2)++    -- | Returns the value at the given key or returns the given+    -- default when the key is not an element of the map.+    findWithDefault :: a -> k i -> m a -> a+++newtype NumMap (k :: Type -> Type) v = NumMap (IntMap v) deriving Functor++lookupNumMap :: a -> Int -> NumMap t a -> a+lookupNumMap d k (NumMap m) = IntMap.findWithDefault d k m++instance Mapping (NumMap k) (Numbered k) where+    NumMap m1 & NumMap m2 = NumMap (IntMap.union m1 m2)+    Numbered k _ |-> v = NumMap $ IntMap.singleton k v+    empty = NumMap IntMap.empty++    findWithDefault d (Numbered i _) m = lookupNumMap d i m++    prodMap p q (NumMap mp) (NumMap mq) = NumMap $ IntMap.mergeWithKey merge +                                          (IntMap.map (,q)) (IntMap.map (p,)) mp mq+      where merge _ p q = Just (p,q)
− src/Data/Comp/Multi/Number.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE TypeOperators #-}------------------------------------------------------------------------------------- |--- Module      :  Data.Comp.Multi.Number--- Copyright   :  (c) 2012 Patrick Bahr--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)--- --- This module provides functionality to number the components of a--- functorial value with consecutive integers.--------------------------------------------------------------------------------------module Data.Comp.Multi.Number -    ( Numbered (..)-    , unNumbered-    , number-    , HTraversable ()) where--import Data.Comp.Multi.HTraversable-import Data.Comp.Multi.HFunctor-import Data.Comp.Multi.Ordering-import Data.Comp.Multi.Equality---import Control.Monad.State----- | This type is used for numbering components of a functorial value.-newtype Numbered a i = Numbered (Int, a i)--unNumbered :: Numbered a :-> a-unNumbered (Numbered (_, x)) = x--instance KEq (Numbered a) where-  keq (Numbered (i,_))  (Numbered (j,_)) = i == j--instance KOrd (Numbered a) where-    kcompare (Numbered (i,_))  (Numbered (j,_)) = i `compare` j---- | This function numbers the components of the given functorial--- value with consecutive integers starting at 0.-number :: HTraversable f => f a :-> f (Numbered a)-number x = fst $ runState (hmapM run x) 0 where-  run b = do n <- get-             put (n+1)-             return $ Numbered (n,b)
src/Data/Comp/Multi/Ops.hs view
@@ -1,8 +1,18 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,-             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,-             ScopedTypeVariables, FunctionalDependencies, UndecidableInstances, KindSignatures, RankNTypes{-|-  --} #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE TypeSynonymInstances   #-}+{-# LANGUAGE UndecidableInstances   #-}  -------------------------------------------------------------------------------- -- |@@ -18,22 +28,30 @@ -- -------------------------------------------------------------------------------- -module Data.Comp.Multi.Ops where+module Data.Comp.Multi.Ops +    ( module Data.Comp.Multi.Ops+    , (O.:*:)(..)+    , O.ffst+    , O.fsnd+    ) where -import Data.Comp.Multi.HFunctor++import Control.Monad+import Data.Kind+ import Data.Comp.Multi.HFoldable+import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable import qualified Data.Comp.Ops as O-import Control.Monad-import Control.Applicative +import Data.Comp.SubsumeCommon -infixr 5 :+:+infixr 6 :+:   -- |Data type defining coproducts.-data (f :+: g) (h :: * -> *) e = Inl (f h e)-                    | Inr (g h e)+data (f :+: g) (h :: Type -> Type) e = Inl (f h e)+                                     | Inr (g h e)  {-| Utility function to case on a higher-order functor sum, without exposing the   internal representation of sums. -}@@ -67,50 +85,87 @@     hmapM f (Inl e) = Inl `liftM` hmapM f e     hmapM f (Inr e) = Inr `liftM` hmapM f e --- |The subsumption relation.-class (sub :: (* -> *) -> * -> *) :<: sup where-    inj :: sub a :-> sup a-    proj :: NatM Maybe (sup a) (sub a)+-- The subsumption relation. -instance (:<:) f f where-    inj = id-    proj = Just+infixl 5 :<:+infixl 5 :=: -instance (:<:) f (f :+: g) where-    inj = Inl-    proj (Inl x) = Just x-    proj (Inr _) = Nothing+type family Elem (f :: (Type -> Type) -> Type -> Type)+                 (g :: (Type -> Type) -> Type -> Type) :: Emb where+    Elem f f = Found Here+    Elem (f1 :+: f2) g =  Sum' (Elem f1 g) (Elem f2 g)+    Elem f (g1 :+: g2) = Choose (Elem f g1) (Elem f g2)+    Elem f g = NotFound -instance (f :<: g) => (:<:) f (h :+: g) where-    inj = Inr . inj-    proj (Inr x) = proj x-    proj (Inl _) = Nothing+class Subsume (e :: Emb) (f :: (Type -> Type) -> Type -> Type)+                         (g :: (Type -> Type) -> Type -> Type) where+  inj'  :: Proxy e -> f a :-> g a+  prj'  :: Proxy e -> NatM Maybe (g a) (f a) --- Products+instance Subsume (Found Here) f f where+    inj' _ = id -infixr 8 :*:+    prj' _ = Just -data (f :*: g) a = f a :*: g a+instance Subsume (Found p) f g => Subsume (Found (Le p)) f (g :+: g') where+    inj' _ = Inl . inj' (P :: Proxy (Found p)) +    prj' _ (Inl x) = prj' (P :: Proxy (Found p)) x+    prj' _ _       = Nothing -fst :: (f :*: g) a -> f a-fst (x :*: _) = x+instance Subsume (Found p) f g => Subsume (Found (Ri p)) f (g' :+: g) where+    inj' _ = Inr . inj' (P :: Proxy (Found p)) -snd :: (f :*: g) a -> g a-snd (_ :*: x) = x+    prj' _ (Inr x) = prj' (P :: Proxy (Found p)) x+    prj' _ _       = Nothing +instance (Subsume (Found p1) f1 g, Subsume (Found p2) f2 g)+    => Subsume (Found (Sum p1 p2)) (f1 :+: f2) g where+    inj' _ (Inl x) = inj' (P :: Proxy (Found p1)) x+    inj' _ (Inr x) = inj' (P :: Proxy (Found p2)) x++    prj' _ x = case prj' (P :: Proxy (Found p1)) x of+                 Just y -> Just (Inl y)+                 _      -> case prj' (P :: Proxy (Found p2)) x of+                             Just y -> Just (Inr y)+                             _      -> Nothing++++-- | A constraint @f :<: g@ expresses that the signature @f@ is+-- subsumed by @g@, i.e. @f@ can be used to construct elements in @g@.+type f :<: g = (Subsume (ComprEmb (Elem f g)) f g)+++inj :: forall f g a . (f :<: g) => f a :-> g a+inj = inj' (P :: Proxy (ComprEmb (Elem f g)))++proj :: forall f g a . (f :<: g) => NatM Maybe (g a) (f a)+proj = prj' (P :: Proxy (ComprEmb (Elem f g)))++type f :=: g = (f :<: g, g :<: f)++++spl :: (f :=: f1 :+: f2) => (f1 a :-> b) -> (f2 a :-> b) -> f a :-> b+spl f1 f2 x = case inj x of+            Inl y -> f1 y+            Inr y -> f2 y+ -- Constant Products  infixr 7 :&:  -- | This data type adds a constant product to a -- signature. Alternatively, this could have also been defined as--- --- @data (f :&: a) (g ::  * -> *) e = f g e :&: a e@--- +--+-- @+-- data (f :&: a) (g ::  Type -> Type) e = f g e :&: a e+-- @+-- -- This is too general, however, for example for 'productHHom'. -data (f :&: a) (g ::  * -> *) e = f g e :&: a+data (f :&: a) (g ::  Type -> Type) e = f g e :&: a   instance (HFunctor f) => HFunctor (f :&: a) where@@ -131,13 +186,13 @@  -- | This class defines how to distribute an annotation over a sum of -- signatures.-class DistAnn (s :: (* -> *) -> * -> *) p s' | s' -> s, s' -> p where+class DistAnn (s :: (Type -> Type) -> Type -> Type) p s' | s' -> s, s' -> p where     -- | This function injects an annotation over a signature.     injectA :: p -> s a :-> s' a     projectA :: s' a :-> (s a O.:&: p)  -class RemA (s :: (* -> *) -> * -> *) s' | s -> s'  where+class RemA (s :: (Type -> Type) -> Type -> Type) s' | s -> s'  where     remA :: s a :-> s' a
src/Data/Comp/Multi/Ordering.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,-  UndecidableInstances, IncoherentInstances, GADTs #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Ordering@@ -19,11 +22,10 @@      OrdHF(..)     ) where -import Data.Comp.Multi.Term-import Data.Comp.Multi.Sum-import Data.Comp.Multi.Ops-import Data.Comp.Multi.HFunctor import Data.Comp.Multi.Equality+import Data.Comp.Multi.HFunctor+import Data.Comp.Multi.Ops+import Data.Comp.Multi.Term  class KEq f => KOrd f where     kcompare :: f i -> f j -> Ordering
+ src/Data/Comp/Multi/Projection.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Multi.Projection+-- Copyright   :  (c) 2014 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@di.ku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides a generic projection function 'pr' for+-- arbitrary nested binary products.+--+--------------------------------------------------------------------------------+++module Data.Comp.Multi.Projection (pr, (:<), (:*:)(..), ffst, fsnd) where++import Data.Comp.SubsumeCommon+import Data.Comp.Multi.Ops hiding (Elem)++import Data.Kind++type family Elem (f :: Type -> Type)+                 (g :: Type -> Type) :: Emb where+    Elem f f = Found Here+    Elem (f1 :*: f2) g =  Sum' (Elem f1 g) (Elem f2 g)+    Elem f (g1 :*: g2) = Choose (Elem f g1) (Elem f g2)+    Elem f g = NotFound++class Proj (e :: Emb) (p :: Type -> Type)+                      (q :: Type -> Type) where+    pr'  :: Proxy e -> q a -> p a++instance Proj (Found Here) f f where+    pr' _ = id++instance Proj (Found p) f g => Proj (Found (Le p)) f (g :*: g') where+    pr' _ = pr' (P :: Proxy (Found p)) . ffst+++instance Proj (Found p) f g => Proj (Found (Ri p)) f (g' :*: g) where+    pr' _ = pr' (P :: Proxy (Found p)) . fsnd+++instance (Proj (Found p1) f1 g, Proj (Found p2) f2 g)+    => Proj (Found (Sum p1 p2)) (f1 :*: f2) g where+    pr' _ x = (pr' (P :: Proxy (Found p1)) x :*: pr' (P :: Proxy (Found p2)) x)+++infixl 5 :<++-- | The constraint @e :< p@ expresses that @e@ is a component of the+-- type @p@. That is, @p@ is formed by binary products using the type+-- @e@. The occurrence of @e@ must be unique. For example we have @Int+-- :< (Bool,(Int,Bool))@ but not @Bool :< (Bool,(Int,Bool))@.++type f :< g = (Proj (ComprEmb (Elem f g)) f g)+++-- | This function projects the component of type @e@ out or the+-- compound value of type @p@.++pr :: forall p q a . (p :< q) => q a -> p a+pr = pr' (P :: Proxy (ComprEmb (Elem p q)))
src/Data/Comp/Multi/Show.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE TypeOperators, GADTs, FlexibleContexts,-  ScopedTypeVariables, UndecidableInstances, FlexibleInstances,-  TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Show@@ -20,11 +23,11 @@     ( ShowHF(..)     ) where -import Data.Comp.Multi.Term-import Data.Comp.Multi.Annotation import Data.Comp.Multi.Algebra-import Data.Comp.Multi.HFunctor+import Data.Comp.Multi.Annotation import Data.Comp.Multi.Derive+import Data.Comp.Multi.HFunctor+import Data.Comp.Multi.Term  instance KShow (K String) where     kshow = id
src/Data/Comp/Multi/Sum.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables, IncoherentInstances,-  Rank2Types, FlexibleContexts, TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Sum@@ -22,72 +26,18 @@       -- * Projections for Signatures and Terms      proj,-     proj2,-     proj3,-     proj4,-     proj5,-     proj6,-     proj7,-     proj8,-     proj9,-     proj10,      project,-     project2,-     project3,-     project4,-     project5,-     project6,-     project7,-     project8,-     project9,-     project10,      deepProject,-     deepProject2,-     deepProject3,-     deepProject4,-     deepProject5,-     deepProject6,-     deepProject7,-     deepProject8,-     deepProject9,-     deepProject10,       -- * Injections for Signatures and Terms      inj,-     inj2,-     inj3,-     inj4,-     inj5,-     inj6,-     inj7,-     inj8,-     inj9,-     inj10,      inject,-     inject2,-     inject3,-     inject4,-     inject5,-     inject6,-     inject7,-     inject8,-     inject9,-     inject10,      deepInject,-     deepInject2,-     deepInject3,-     deepInject4,-     deepInject5,-     deepInject6,-     deepInject7,-     deepInject8,-     deepInject9,-     deepInject10, +     split,+      -- * Injections and Projections for Constants      injectConst,-     injectConst2,-     injectConst3,      projectConst,      injectCxt,      liftCxt,@@ -95,16 +45,12 @@ --     substHoles'     ) where +import Data.Comp.Multi.Algebra import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable import Data.Comp.Multi.Ops import Data.Comp.Multi.Term-import Data.Comp.Multi.Algebra-import Data.Comp.Multi.Derive.Projections-import Data.Comp.Multi.Derive.Injections-import Control.Monad (liftM) -$(liftM concat $ mapM projn [2..10])  -- |Project the outermost layer of a term to a sub signature. If the signature -- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.@@ -112,7 +58,6 @@ project (Hole _) = Nothing project (Term t) = proj t -$(liftM concat $ mapM projectn [2..10])  -- | Tries to coerce a term/context to a term/context over a sub-signature. If -- the signature @g@ is compound of /n/ atomic signatures, use@@ -121,25 +66,12 @@ {-# INLINE deepProject #-} deepProject = appSigFunM' proj -$(liftM concat $ mapM deepProjectn [2..10])-{-# INLINE deepProject2 #-}-{-# INLINE deepProject3 #-}-{-# INLINE deepProject4 #-}-{-# INLINE deepProject5 #-}-{-# INLINE deepProject6 #-}-{-# INLINE deepProject7 #-}-{-# INLINE deepProject8 #-}-{-# INLINE deepProject9 #-}-{-# INLINE deepProject10 #-} -$(liftM concat $ mapM injn [2..10])- -- |Inject a term where the outermost layer is a sub signature. If the signature -- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead. inject :: (g :<: f) => g (Cxt h f a) :-> Cxt h f a inject = Term . inj -$(liftM concat $ mapM injectn [2..10])  -- |Inject a term over a sub signature to a term over larger signature. If the -- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/@@ -148,17 +80,11 @@ {-# INLINE deepInject #-} deepInject = appSigFun inj -$(liftM concat $ mapM deepInjectn [2..10])-{-# INLINE deepInject2 #-}-{-# INLINE deepInject3 #-}-{-# INLINE deepInject4 #-}-{-# INLINE deepInject5 #-}-{-# INLINE deepInject6 #-}-{-# INLINE deepInject7 #-}-{-# INLINE deepInject8 #-}-{-# INLINE deepInject9 #-}-{-# INLINE deepInject10 #-} +split :: (f :=: f1 :+: f2) => (f1 (Term f) :-> a) -> (f2 (Term f) :-> a) -> Term f :-> a+split f1 f2 (Term t) = spl f1 f2 t++ -- | This function injects a whole context into another context. injectCxt :: (HFunctor g, g :<: f) => Cxt h' g (Cxt h f a) :-> Cxt h f a injectCxt = cata' inject@@ -177,15 +103,6 @@  injectConst :: (HFunctor g, g :<: f) => Const g :-> Cxt h f a injectConst = inject . hfmap (const undefined)--injectConst2 :: (HFunctor f1, HFunctor f2, HFunctor g, f1 :<: g, f2 :<: g)-               => Const (f1 :+: f2) :-> Cxt h g a-injectConst2 = inject2 . hfmap (const undefined)--injectConst3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g,-                   f1 :<: g, f2 :<: g, f3 :<: g)-               => Const (f1 :+: f2 :+: f3) :-> Cxt h g a-injectConst3 = inject3 . hfmap (const undefined)  projectConst :: (HFunctor g, g :<: f) => NatM Maybe (Cxt h f a) (Const g) projectConst = fmap (hfmap (const (K ()))) . project
src/Data/Comp/Multi/Term.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, RankNTypes,-  TypeOperators, ScopedTypeVariables, IncoherentInstances #-}+{-# LANGUAGE EmptyDataDecls      #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Term@@ -15,7 +19,7 @@ -- -------------------------------------------------------------------------------- -module Data.Comp.Multi.Term +module Data.Comp.Multi.Term     (Cxt (..),      Hole,      NoHole,@@ -28,17 +32,17 @@      simpCxt      ) where -import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HFoldable+import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable-import Data.Monoid +import Data.Kind+ import Control.Monad-import Control.Applicative hiding (Const)  import Unsafe.Coerce -type Const (f :: (* -> *) -> * -> *) = f (K ())+type Const (f :: (Type -> Type) -> Type -> Type) = f (K ())  -- | This function converts a constant to a term. This assumes that -- the argument is indeed a constant, i.e. does not have a value for@@ -79,9 +83,9 @@  instance (HFoldable f) => HFoldable (Cxt h f) where     hfoldr = hfoldr' where-        hfoldr'  :: forall a b. (a :=> b -> b) -> b -> Cxt h f a :=> b+        hfoldr'  :: forall a b. (a :=> (b -> b)) -> b -> Cxt h f a :=> b         hfoldr' op c a = run a c where-              run :: (Cxt h f) a :=> b ->  b+              run :: (Cxt h f) a :=> (b ->  b)               run (Hole a) e = a `op` e               run (Term t) e = hfoldr run e t
src/Data/Comp/Multi/Variables.hs view
@@ -1,5 +1,12 @@-{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,-  OverlappingInstances, TypeOperators, KindSignatures, FlexibleContexts, ScopedTypeVariables, RankNTypes, TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeOperators         #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Multi.Variables@@ -28,17 +35,21 @@      variables',      appSubst,      compSubst,-     getBoundVars+     getBoundVars,+    (&),+    (|->),+    empty     ) where -import Data.Comp.Multi.Term-import Data.Comp.Multi.Ordering-import Data.Comp.Multi.Number-import Data.Comp.Multi.Ops import Data.Comp.Multi.Algebra import Data.Comp.Multi.Derive-import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HFoldable+import Data.Comp.Multi.HFunctor+import Data.Comp.Multi.Mapping+import Data.Comp.Multi.Ops+import Data.Comp.Multi.Term++import Data.Kind import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set)@@ -61,38 +72,42 @@ {-| This multiparameter class defines functors with variables. An instance   @HasVar f v@ denotes that values over @f@ might contain and bind variables of   type @v@. -}-class HasVars (f  :: (* -> *) -> * -> *) v where+class HasVars (f  :: (Type -> Type) -> Type -> Type) v where     -- | Indicates whether the @f@ constructor is a variable. The     -- default implementation returns @Nothing@.     isVar :: f a :=> Maybe v     isVar _ = Nothing-    +     -- | Indicates the set of variables bound by the @f@ constructor     -- for each argument of the constructor. For example for a     -- non-recursive let binding:+    --      -- @     -- data Let i e = Let Var (e i) (e i)     -- instance HasVars Let Var where-    --   bindsVars (Let v x y) = Map.fromList [(y, (Set.singleton v))]+    --   bindsVars (Let v x y) = y |-> Set.singleton v     -- @+    --      -- If, instead, the let binding is recursive, the methods has to     -- be implemented like this:+    --      -- @-    --   bindsVars (Let v x y) = Map.fromList [(x, (Set.singleton v)),-    --                                         (y, (Set.singleton v))]+    --   bindsVars (Let v x y) = x |-> Set.singleton v &+    --                           y |-> Set.singleton v     -- @+    --      -- This indicates that the scope of the bound variable also     -- extends to the right-hand side of the variable binding.     --     -- The default implementation returns the empty map.-    bindsVars :: KOrd a => f a :=> Map (E a) (Set v)-    bindsVars _ = Map.empty+    bindsVars :: Mapping m a => f a :=> m (Set v)+    bindsVars _ = empty  $(derive [liftSum] [''HasVars])-    + -- | Same as 'isVar' but it returns Nothing@ instead of @Just v@ if -- @v@ is contained in the given set of variables.-    + isVar' :: (HasVars f v, Ord v) => Set v -> f a :=> Maybe v isVar' b t = do v <- isVar t                 if v `Set.member` b@@ -105,32 +120,29 @@ getBoundVars :: forall f a v i . (HasVars f v, HTraversable f) => f a i -> f (a :*: K (Set v)) i getBoundVars t = let n :: f (Numbered a) i                      n = number t-                     m :: Map (E (Numbered a)) (Set v)                      m = bindsVars n                      trans :: Numbered a :-> (a :*: K (Set v))-                     trans x = unNumbered x :*: (K (Map.findWithDefault Set.empty (E x) m))+                     trans (Numbered i x) = x :*: K (lookupNumMap Set.empty i m)                  in hfmap trans n-                    + -- | This combinator combines 'getBoundVars' with the 'mfmap' function.-hfmapBoundVars :: forall f a b v i . (HasVars f v, HTraversable f) +hfmapBoundVars :: forall f a b v i . (HasVars f v, HTraversable f)                   => (Set v -> a :-> b) -> f a i -> f b i hfmapBoundVars f t = let n :: f (Numbered a) i                          n = number t-                         m :: Map (E (Numbered a)) (Set v)                          m = bindsVars n                          trans :: Numbered a :-> b-                         trans x = f (Map.findWithDefault Set.empty (E x) m) (unNumbered x)+                         trans (Numbered i x) = f (lookupNumMap Set.empty i m) x                      in hfmap trans n-                        --- | This combinator combines 'getBoundVars' with the generic 'hfoldl' function.   -hfoldlBoundVars :: forall f a b v i . (HasVars f v, HTraversable f) ++-- | This combinator combines 'getBoundVars' with the generic 'hfoldl' function.+hfoldlBoundVars :: forall f a b v i . (HasVars f v, HTraversable f)                   => (b -> Set v ->  a :=> b) -> b -> f a i -> b hfoldlBoundVars f e t = let n :: f (Numbered a) i                             n = number t-                            m :: Map (E (Numbered a)) (Set v)                             m = bindsVars n                             trans :: b -> Numbered a :=> b-                            trans x y = f x (Map.findWithDefault Set.empty (E y) m) (unNumbered y)+                            trans x (Numbered i y) = f x (lookupNumMap Set.empty i m) y                        in hfoldl trans e n  @@ -145,17 +157,17 @@           alg t = C $ \vars -> case isVar t of             Just v | not (v `Set.member` vars) -> Hole $ K v             _  -> Term $ hfmapBoundVars run t-              where +              where                 run :: Set v -> C (Set v) (Context f (K v))  :-> Context f (K v)                 run newVars f = f `unC` (newVars `Set.union` vars)-                + -- | Convert variables to holes, except those that are bound. containsVarAlg :: forall v f . (Ord v, HasVars f v, HTraversable f) => v -> Alg f (K Bool) containsVarAlg v t = K $ hfoldlBoundVars run local t     where local = case isVar t of                     Just v' -> v == v'                     Nothing -> False-          run :: Bool -> Set v -> (K Bool i) -> Bool+          run :: Bool -> Set v -> K Bool i -> Bool           run acc vars (K b) = acc || (not (v `Set.member` vars) && b)  {-| This function checks whether a variable is contained in a context. -}@@ -198,19 +210,20 @@ appSubst :: (Ord v, SubstVars v t a) => GSubst v t -> a :-> a appSubst subst = substVars (substFun subst) -instance (Ord v, HasVars f v, HTraversable f) => SubstVars v (Cxt h f a) (Cxt h f a) where+instance {-# OVERLAPPABLE #-} (Ord v, HasVars f v, HTraversable f)+       => SubstVars v (Cxt h f a) (Cxt h f a) where     -- have to use explicit GADT pattern matching!!     substVars subst = doSubst Set.empty       where doSubst :: Set v -> Cxt h f a :-> Cxt h f a             doSubst _ (Hole a) = Hole a-            doSubst b (Term t) = case isVar' b t >>= subst . K of +            doSubst b (Term t) = case isVar' b t >>= subst . K of               Just new -> new               Nothing  -> Term $ hfmapBoundVars run t                 where run :: Set v -> Cxt h f a :-> Cxt h f a-                      run vars s = doSubst (b `Set.union` vars) s+                      run vars = doSubst (b `Set.union` vars) -instance (SubstVars v t a, HFunctor f) => SubstVars v t (f a) where-    substVars subst = hfmap (substVars subst) +instance {-# OVERLAPPABLE #-} (SubstVars v t a, HFunctor f) => SubstVars v t (f a) where+    substVars subst = hfmap (substVars subst)  {-| This function composes two substitutions @s1@ and @s2@. That is, applying the resulting substitution is equivalent to first applying@@ -218,5 +231,4 @@  compSubst :: (Ord v, HasVars f v, HTraversable f)           => CxtSubst h a f v -> CxtSubst h a f v -> CxtSubst h a f v-compSubst s1 s2 = Map.map f s2-    where f (A t) = A (appSubst s1 t)+compSubst s1 = Map.map (\ (A t) -> A (appSubst s1 t))
− src/Data/Comp/MultiParam.hs 
@@ -1,34 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines the infrastructure necessary to use--- /Generalised Parametric Compositional Data Types/. Generalised Parametric--- Compositional Data Types is an extension of Compositional Data Types with--- parametric higher-order abstract syntax (PHOAS) for usage with binders, and--- GADTs. Generalised Parametric Compositional Data Types combines Generalised--- Compositional Data Types ("Data.Comp.Multi") and Parametric Compositional--- Data Types ("Data.Comp.Param"). Examples of usage are bundled with the--- package in the library @examples\/Examples\/MultiParam@.-------------------------------------------------------------------------------------module Data.Comp.MultiParam (-    module Data.Comp.MultiParam.Term-  , module Data.Comp.MultiParam.Algebra-  , module Data.Comp.MultiParam.HDifunctor-  , module Data.Comp.MultiParam.Sum-  , module Data.Comp.MultiParam.Annotation-  , module Data.Comp.MultiParam.Equality-    ) where--import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.Algebra-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.Sum-import Data.Comp.MultiParam.Annotation-import Data.Comp.MultiParam.Equality
− src/Data/Comp/MultiParam/Algebra.hs 
@@ -1,349 +0,0 @@-{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables, TypeOperators,-  FlexibleContexts, CPP, KindSignatures #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Algebra--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines the notion of algebras and catamorphisms, and their--- generalizations to e.g. monadic versions and other (co)recursion schemes.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Algebra (-      -- * Algebras & Catamorphisms-      Alg,-      free,-      cata,-      cata',-      appCxt,-      -      -- * Monadic Algebras & Catamorphisms-      AlgM,---      algM,-      freeM,-      cataM,-      AlgM',-      Compose(..),-      freeM',-      cataM',--      -- * Term Homomorphisms-      CxtFun,-      SigFun,-      Hom,-      appHom,-      appHom',-      compHom,-      appSigFun,-      appSigFun',-      compSigFun,-      hom,-      compAlg,--      -- * Monadic Term Homomorphisms-      CxtFunM,-      SigFunM,-      HomM,-      sigFunM,-      hom',-      appHomM,-      appTHomM,-      appHomM',-      appTHomM',-      homM,-      appSigFunM,-      appTSigFunM,-      appSigFunM',-      appTSigFunM',-      compHomM,-      compSigFunM,-      compAlgM,-      compAlgM'-    ) where--import Prelude hiding (sequence, mapM)-import Control.Monad hiding (sequence, mapM)-import Data.Functor.Compose -- Functor composition-import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.HDitraversable--{-| This type represents an algebra over a difunctor @f@ and carrier @a@. -}-type Alg f a = f a a :-> a--{-| Construct a catamorphism for contexts over @f@ with holes of type @b@, from-  the given algebra. -}-free :: forall h f a b. HDifunctor f-        => Alg f a -> (b :-> a) -> Cxt h f a b :-> a-free f g = run-    where run :: Cxt h f a b :-> a-          run (In t) = f (hfmap run t)-          run (Hole x) = g x-          run (Var p) = p--{-| Construct a catamorphism from the given algebra. -}-cata :: forall f a. HDifunctor f => Alg f a -> Term f :-> a -{-# NOINLINE [1] cata #-}-cata f (Term t) = run t-    where run :: Trm f a :-> a-          run (In t) = f (hfmap run t)-          run (Var x) = x--{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where-  the holes have the type of the algebra carrier. -}-cata' :: HDifunctor f => Alg f a -> Cxt h f a a :-> a-{-# INLINE cata' #-}-cata' f = free f id--{-| This function applies a whole context into another context. -}-appCxt :: HDifunctor f => Cxt Hole f a (Cxt h f a b) :-> Cxt h f a b-appCxt (In t) = In (hfmap appCxt t)-appCxt (Hole x) = x-appCxt (Var p) = Var p--{-| This type represents a monadic algebra. It is similar to 'Alg' but-  the return type is monadic. -}-type AlgM m f a = NatM m (f a a) a--{-| Construct a monadic catamorphism for contexts over @f@ with holes of type-  @b@, from the given monadic algebra. -}-freeM :: forall m h f a b. (HDitraversable f, Monad m)-         => AlgM m f a -> NatM m b a -> NatM m (Cxt h f a b) a-freeM f g = run-    where run :: NatM m (Cxt h f a b) a-          run (In t) = f =<< hdimapM run t-          run (Hole x) = g x-          run (Var p) = return p--{-| Construct a monadic catamorphism from the given monadic algebra. -}-cataM :: forall m f a. (HDitraversable f, Monad m)-         => AlgM m f a -> NatM m (Term f) a-{-# NOINLINE [1] cataM #-}-cataM algm (Term t) = run t-    where run :: NatM m (Trm f a) a-          run (In t) = algm =<< hdimapM run t-          run (Var x) = return x--{-| This type represents a monadic algebra, but where the covariant argument is-  also a monadic computation. -}-type AlgM' m f a = NatM m (f a (Compose m a)) a--{-| Construct a monadic catamorphism for contexts over @f@ with holes of type-  @b@, from the given monadic algebra. -}-freeM' :: forall m h f a b. (HDifunctor f, Monad m)-          => AlgM' m f a -> NatM m b a -> NatM m (Cxt h f a b) a-freeM' f g = run-    where run :: NatM m (Cxt h f a b) a-          run (In t) = f $ hfmap (Compose . run) t-          run (Hole x) = g x-          run (Var p) = return p--{-| Construct a monadic catamorphism from the given monadic algebra. -}-cataM' :: forall m f a. (HDifunctor f, Monad m)-          => AlgM' m f a -> NatM m (Term f) a-{-# NOINLINE [1] cataM' #-}-cataM' algm (Term t) = run t-    where run :: NatM m (Trm f a) a-          run (In t) = algm $ hfmap (Compose . run) t-          run (Var x) = return x--{-| This type represents a signature function. -}-type SigFun f g = forall (a :: * -> *) (b :: * -> *) . f a b :-> g a b--{-| This type represents a context function. -}-type CxtFun f g = forall h. SigFun (Cxt h f) (Cxt h g)--{-| This type represents a term homomorphism. -}-type Hom f g = SigFun f (Context g)--{-| Apply a term homomorphism recursively to a term/context. -}-appHom :: forall f g. (HDifunctor f, HDifunctor g) => Hom f g -> CxtFun f g-{-# INLINE [1] appHom #-}-appHom f = run where-    run :: CxtFun f g-    run (In t) = appCxt (f (hfmap run t))-    run (Hole x) = Hole x-    run (Var p) = Var p---- | Apply a term homomorphism recursively to a term/context. This is--- a top-down variant of 'appHom'.-appHom' :: forall f g. (HDifunctor g)-              => Hom f g -> CxtFun f g-{-# INLINE [1] appHom' #-}-appHom' f = run where-    run :: CxtFun f g-    run (In t) = appCxt (hfmapCxt run (f t))-    run (Hole x) = Hole x-    run (Var p) = Var p--{-| Compose two term homomorphisms. -}-compHom :: (HDifunctor g, HDifunctor h)-               => Hom g h -> Hom f g -> Hom f h-compHom f g = appHom f . g--{-| Compose an algebra with a term homomorphism to get a new algebra. -}-compAlg :: (HDifunctor f, HDifunctor g) => Alg g a -> Hom f g -> Alg f a-compAlg alg talg = cata' alg . talg--{-| This function applies a signature function to the given context. -}-appSigFun :: forall f g. (HDifunctor f) => SigFun f g -> CxtFun f g-appSigFun f = run where-    run :: CxtFun f g-    run (In t) = In (f (hfmap run t))-    run (Hole x) = Hole x-    run (Var p) = Var p--{-| This function applies a signature function to the given context. -}-appSigFun' :: forall f g. (HDifunctor g) => SigFun f g -> CxtFun f g-appSigFun' f = run where-    run :: CxtFun f g-    run (In t) = In (hfmap run (f t))-    run (Hole x) = Hole x-    run (Var p) = Var p--{-| This function composes two signature functions. -}-compSigFun :: SigFun g h -> SigFun f g -> SigFun f h-compSigFun f g = f . g--{-| Lifts the given signature function to the canonical term homomorphism. -}-hom :: HDifunctor g => SigFun f g -> Hom f g-hom f = simpCxt . f--{-| This type represents a monadic signature function. -}-type SigFunM m f g = forall (a :: * -> *) (b :: * -> *) . NatM m (f a b) (g a b)--{-| This type represents a monadic context function. -}-type CxtFunM m f g = forall h . SigFunM m (Cxt h f) (Cxt h g)--{-| This type represents a monadic term homomorphism. -}-type HomM m f g = SigFunM m f (Cxt Hole g)---{-| Lift the given signature function to a monadic signature function. Note that-  term homomorphisms are instances of signature functions. Hence this function-  also applies to term homomorphisms. -}-sigFunM :: Monad m => SigFun f g -> SigFunM m f g-sigFunM f = return . f--{-| Lift the give monadic signature function to a monadic term homomorphism. -}-hom' :: (HDifunctor f, HDifunctor g, Monad m)-            => SigFunM m f g -> HomM m f g-hom' f = liftM  (In . hfmap Hole) . f--{-| Lift the given signature function to a monadic term homomorphism. -}-homM :: (HDifunctor g, Monad m) => SigFun f g -> HomM m f g-homM f = sigFunM $ hom f--{-| Apply a monadic term homomorphism recursively to a term/context. -}-appHomM :: forall f g m. (HDitraversable f, Monad m, HDifunctor g)-               => HomM m f g -> CxtFunM m f g-{-# NOINLINE [1] appHomM #-}-appHomM f = run-    where run :: CxtFunM m f g-          run (In t) = liftM appCxt (f =<< hdimapM run t)-          run (Hole x) = return (Hole x)-          run (Var p) = return (Var p)--{-| A restricted form of |appHomM| which only works for terms. -}-appTHomM :: (HDitraversable f, Monad m, ParamFunctor m, HDifunctor g)-            => HomM m f g -> Term f i -> m (Term g i)-appTHomM f (Term t) = termM (appHomM f t)---- | Apply a monadic term homomorphism recursively to a--- term/context. This is a top-down variant of 'appHomM'.-appHomM' :: forall f g m. (HDitraversable g, Monad m)-            => HomM m f g -> CxtFunM m f g-{-# NOINLINE [1] appHomM' #-}-appHomM' f = run-    where run :: CxtFunM m f g-          run (In t) = liftM appCxt (hdimapMCxt run =<<  f t)-          run (Hole x) = return (Hole x)-          run (Var p) = return (Var p)--{-| A restricted form of |appHomM'| which only works for terms. -}-appTHomM' :: (HDitraversable g, Monad m, ParamFunctor m, HDifunctor g)-             => HomM m f g -> Term f i -> m (Term g i)-appTHomM' f (Term t) = termM (appHomM' f t)--{-| This function applies a monadic signature function to the given context. -}-appSigFunM :: forall m f g. (HDitraversable f, Monad m)-              => SigFunM m f g -> CxtFunM m f g-appSigFunM f = run-    where run :: CxtFunM m f g-          run (In t)   = liftM In (f =<< hdimapM run t)-          run (Hole x) = return (Hole x)-          run (Var p)  = return (Var p)--{-| A restricted form of |appSigFunM| which only works for terms. -}-appTSigFunM :: (HDitraversable f, Monad m, ParamFunctor m, HDifunctor g)-               => SigFunM m f g -> Term f i -> m (Term g i)-appTSigFunM f (Term t) = termM (appSigFunM f t)---- | This function applies a monadic signature function to the given--- context. This is a top-down variant of 'appSigFunM'.-appSigFunM' :: forall m f g. (HDitraversable g, Monad m)-               => SigFunM m f g -> CxtFunM m f g-appSigFunM' f = run-    where run :: CxtFunM m f g-          run (In t)   = liftM In (hdimapM run =<< f t)-          run (Hole x) = return (Hole x)-          run (Var p)  = return (Var p)--{-| A restricted form of |appSigFunM'| which only works for terms. -}-appTSigFunM' :: (HDitraversable g, Monad m, ParamFunctor m, HDifunctor g)-                => SigFunM m f g -> Term f i -> m (Term g i)-appTSigFunM' f (Term t) = termM (appSigFunM' f t)--{-| Compose two monadic term homomorphisms. -}-compHomM :: (HDitraversable g, HDifunctor h, Monad m)-                => HomM m g h -> HomM m f g -> HomM m f h-compHomM f g = appHomM f <=< g--{-| Compose a monadic algebra with a monadic term homomorphism to get a new-  monadic algebra. -}-compAlgM :: (HDitraversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a-compAlgM alg talg = freeM alg return <=< talg--{-| Compose a monadic algebra with a term homomorphism to get a new monadic-  algebra. -}-compAlgM' :: (HDitraversable g, Monad m) => AlgM m g a -> Hom f g -> AlgM m f a-compAlgM' alg talg = freeM alg return . talg--{-| This function composes two monadic signature functions. -}-compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h-compSigFunM f g a = g a >>= f--{--#ifndef NO_RULES-{-# RULES-  "cata/appHom" forall (a :: Alg g d) (h :: Hom f g) x.-    cata a (appHom h x) = cata (compAlg a h) x;--  "appHom/appHom" forall (a :: Hom g h) (h :: Hom f g) x.-    appHom a (appHom h x) = appHom (compHom a h) x;- #-}--{--{-# RULES -  "cataM/appHomM" forall (a :: AlgM m g d) (h :: HomM m f g d) x.-     appHomM h x >>= cataM a = cataM (compAlgM a h) x;--  "cataM/appHom" forall (a :: AlgM m g d) (h :: Hom f g) x.-     cataM a (appHom h x) = cataM (compAlgM' a h) x;--  "appHomM/appHomM" forall (a :: HomM m g h b) (h :: HomM m f g b) x.-    appHomM h x >>= appHomM a = appHomM (compHomM a h) x;- #-}--{-# RULES-  "cata/build"  forall alg (g :: forall a . Alg f a -> a) .-                cata alg (build g) = g alg- #-}--}-#endif--}
− src/Data/Comp/MultiParam/Annotation.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,-  UndecidableInstances, Rank2Types, GADTs, ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Annotation--- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines annotations on signatures.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Annotation-    (-     (:&:) (..),-     (:*:) (..),-     DistAnn (..),-     RemA (..),-     liftA,-     liftA',-     stripA,-     propAnn,-     propAnnM,-     ann,-     project'-    ) where--import qualified Data.Comp.Ops as O-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.Sum-import Data.Comp.MultiParam.Ops-import Data.Comp.MultiParam.Algebra--import Control.Monad--{-| Transform a function with a domain constructed from a higher-order difunctor-  to a function with a domain constructed with the same higher-order difunctor,-  but with an additional annotation. -}-liftA :: (RemA s s') => (s' a b :-> t) -> s a b :-> t-liftA f v = f (remA v)--{-| Transform a function with a domain constructed from a higher-order difunctor-  to a function with a domain constructed with the same higher-order difunctor,-  but with an additional annotation. -}-liftA' :: (DistAnn s' p s, HDifunctor s')-          => (s' a b :-> Cxt h s' c d) -> s a b :-> Cxt h s c d-liftA' f v = let v' O.:&: p = projectA v-             in ann p (f v')--{-| Strip the annotations from a term over a higher-order difunctor with-  annotations. -}-stripA :: (RemA g f, HDifunctor g) => CxtFun g f-stripA = appSigFun remA--{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism- over the same signatures, but extended with annotations. -}-propAnn :: (DistAnn f p f', DistAnn g p g', HDifunctor g) -           => Hom f g -> Hom f' g'-propAnn hom f' = ann p (hom f)-    where f O.:&: p = projectA f'--{-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic-  term homomorphism over the same signatures, but extended with annotations. -}-propAnnM :: (DistAnn f p f', DistAnn g p g', HDifunctor g, Monad m)-         => HomM m f g -> HomM m f' g'-propAnnM hom f' = liftM (ann p) (hom f)-    where f O.:&: p = projectA f'--{-| Annotate each node of a term with a constant value. -}-ann :: (DistAnn f p g, HDifunctor f) => p -> CxtFun f g-ann c = appSigFun (injectA c)--{-| This function is similar to 'project' but applies to signatures-  with an annotation which is then ignored. -}-project' :: forall s s' f a b i h . (RemA s s', s :<: f) =>  Cxt h f a b i -> Maybe (s' a (Cxt h f a b) i)-project' v = liftM remA (project v :: Maybe (s a (Cxt h f a b) i))
− src/Data/Comp/MultiParam/Derive.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module contains functionality for automatically deriving boilerplate--- code using Template Haskell. Examples include instances of 'HDifunctor',--- 'ShowHD', and 'EqHD'.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive-    (-     derive,-     -- |Derive boilerplate instances for parametric signatures, i.e.-     -- signatures for parametric compositional data types.--     -- ** EqHD-     module Data.Comp.MultiParam.Derive.Equality,-     -- ** OrdHD-     module Data.Comp.MultiParam.Derive.Ordering,-     -- ** ShowHD-     module Data.Comp.MultiParam.Derive.Show,-     -- ** HDifunctor-     module Data.Comp.MultiParam.Derive.HDifunctor,-     -- ** Smart Constructors-     module Data.Comp.MultiParam.Derive.SmartConstructors,-     -- ** Smart Constructors w/ Annotations-     module Data.Comp.MultiParam.Derive.SmartAConstructors,-     -- ** Lifting to Sums-     liftSum-    ) where--import Data.Comp.Derive.Utils (derive, liftSumGen)-import Data.Comp.MultiParam.Derive.Equality-import Data.Comp.MultiParam.Derive.Ordering-import Data.Comp.MultiParam.Derive.Show-import Data.Comp.MultiParam.Derive.HDifunctor-import Data.Comp.MultiParam.Derive.SmartConstructors-import Data.Comp.MultiParam.Derive.SmartAConstructors-import Data.Comp.MultiParam.Ops ((:+:), caseHD)--import Language.Haskell.TH--{-| Given the name of a type class, where the first parameter is a higher-order-  difunctor, lift it to sums of higher-order difunctors. Example:-  @class ShowHD f where ...@ is lifted as-  @instance (ShowHD f, ShowHD g) => ShowHD (f :+: g) where ... @. -}-liftSum :: Name -> Q [Dec]-liftSum = liftSumGen 'caseHD ''(:+:)
− src/Data/Comp/MultiParam/Derive/Equality.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,-  ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.Equality--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @EqHD@.-------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.Equality-    (-     EqHD(..),-     makeEqHD-    ) where--import Data.Comp.Derive.Utils-import Data.Comp.MultiParam.FreshM hiding (Name)-import Data.Comp.MultiParam.Equality-import Control.Monad-import Language.Haskell.TH hiding (Cxt, match)--{-| Derive an instance of 'EqHD' for a type constructor of any parametric-  kind taking at least three arguments. -}-makeEqHD :: Name -> Q [Dec]-makeEqHD fname = do-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  let args' = init args-  -- covariant argument-  let coArg :: Name = tyVarBndrName $ last args'-  -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'-  let argNames = map (VarT . tyVarBndrName) (init $ init args')-  let complType = foldl AppT (ConT name) argNames-  let classType = AppT (ConT ''EqHD) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  let defC = if length constrs < 2 then-                 []-             else-                 [clause [wildP,wildP] (normalB [|return False|]) []]-  eqHDDecl <- funD 'eqHD (map (eqHDClause conArg coArg) constrs' ++ defC)-  let context = map (\arg -> ClassP ''Eq [arg]) argNames-  return [InstanceD context classType [eqHDDecl]]-      where eqHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            eqHDClause conArg coArg (constr, args) = do-              varXs <- newNames (length args) "x"-              varYs <- newNames (length args) "y"-              -- Patterns for the constructors-              let patx = ConP constr $ map VarP varXs-              let paty = ConP constr $ map VarP varYs-              body <- eqHDBody conArg coArg (zip3 varXs varYs args)-              return $ Clause [patx,paty] (NormalB body) []-            eqHDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ-            eqHDBody conArg coArg x =-                [|liftM and (sequence $(listE $ map (eqHDB conArg coArg) x))|]-            eqHDB :: Name -> Name -> (Name, Name, Type) -> ExpQ-            eqHDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =-                    [| return $ $(varE x) == $(varE y) |]-                | otherwise =-                    case tp of-                      AppT (VarT a) _ -                          | a == coArg -> [| peq $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (AppT (VarT a) _)) _-                          | a == conArg ->-                              [| withName (\v -> peq ($(varE x) $ nameCoerce v)                                                      ($(varE y) $ nameCoerce v)) |]-                      SigT tp' _ ->-                          eqHDB conArg coArg (x, y, tp')-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| eqHD $(varE x) $(varE y) |]-                          else-                              [| peq $(varE x) $(varE y) |]
− src/Data/Comp/MultiParam/Derive/HDifunctor.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.HDifunctor--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @HDifunctor@.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.HDifunctor-    (-     HDifunctor,-     makeHDifunctor-    ) where--import Data.Comp.Derive.Utils-import Data.Comp.MultiParam.HDifunctor-import Language.Haskell.TH--{-| Derive an instance of 'HDifunctor' for a type constructor of any parametric-  kind taking at least three arguments. -}-makeHDifunctor :: Name -> Q [Dec]-makeHDifunctor fname = do-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  let args' = init args-  -- covariant argument-  let coArg :: Name = tyVarBndrName $ last args'-  -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'-  let argNames = map (VarT . tyVarBndrName) (init $ init args')-  let complType = foldl AppT (ConT name) argNames-  let classType = AppT (ConT ''HDifunctor) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  hdimapDecl <- funD 'hdimap (map (hdimapClause conArg coArg) constrs')-  return [InstanceD [] classType [hdimapDecl]]-      where hdimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            hdimapClause conArg coArg (constr, args) = do-              fn <- newName "_f"-              gn <- newName "_g"-              varNs <- newNames (length args) "x"-              let f = varE fn-              let g = varE gn-              let fp = VarP fn-              let gp = VarP gn-              -- Pattern for the constructor-              let pat = ConP constr $ map VarP varNs-              body <- hdimapArgs conArg coArg f g (zip varNs args) (conE constr)-              return $ Clause [fp, gp, pat] (NormalB body) []-            hdimapArgs :: Name -> Name -> ExpQ -> ExpQ-                      -> [(Name, Type)] -> ExpQ -> ExpQ-            hdimapArgs _ _ _ _ [] acc =-                acc-            hdimapArgs conArg coArg f g ((x,tp):tps) acc =-                hdimapArgs conArg coArg f g tps-                          (acc `appE` (hdimapArg conArg coArg tp f g `appE` varE x))-            hdimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ-            hdimapArg conArg coArg tp f g-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) = [| id |]-                | otherwise =-                    case tp of-                      AppT (VarT a) _ | a == conArg -> f-                                      | a == coArg -> g-                      AppT (AppT ArrowT tp1) tp2 -> do-                          xn <- newName "x"-                          let ftp1 = hdimapArg conArg coArg tp1 f g-                          let ftp2 = hdimapArg conArg coArg tp2 f g-                          lamE [varP xn]-                               (infixE (Just ftp2)-                                       [|(.)|]-                                       (Just $ infixE (Just $ varE xn)-                                                      [|(.)|]-                                                      (Just ftp1)))-                      SigT tp' _ ->-                          hdimapArg conArg coArg tp' f g-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| hdimap $f $g |]-                          else-                              [| fmap $g |]
− src/Data/Comp/MultiParam/Derive/Injections.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.Injections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature injections.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.Injections-    (-     injn,-     injectn,-     deepInjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.Algebra (CxtFun, appSigFun)-import Data.Comp.MultiParam.Ops ((:+:)(..), (:<:)(..))--injn :: Int -> Q [Dec]-injn n = do-  let i = mkName $ "inj" ++ show n-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let bvar = mkName "b"-  let ivar = mkName "i"-  let xvar = mkName "x"-  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ sigD i (genSig fvars gvar avar bvar ivar) : d-    where genSig fvars gvar avar bvar ivar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = arrowT `appT` (tp `appT` varT avar `appT`-                                     varT bvar `appT` varT ivar)-                             `appT` (varT gvar `appT` varT avar `appT`-                                     varT bvar `appT` varT ivar)-            forallT (map PlainTV $ gvar : avar : bvar : ivar : fvars)-                    (sequence cxt) tp'-          genDecl x n = [| case $(varE x) of-                             Inl x -> $(varE $ mkName "inj") x-                             Inr x -> $(varE $ mkName $ "inj" ++-                                        if n > 2 then show (n - 1) else "") x |]-injectn :: Int -> Q [Dec]-injectn n = do-  let i = mkName ("inject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let bvar = mkName "b"-  let ivar = mkName "i"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar avar bvar ivar) : d-    where genSig fvars gvar avar bvar ivar = do-            let hvar = mkName "h"-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar-                                 `appT` varT avar `appT` varT bvar-            let tp'' = arrowT `appT` (tp `appT` varT avar `appT`-                                      tp' `appT` varT ivar)-                              `appT` (tp' `appT` varT ivar)-            forallT (map PlainTV $ hvar : gvar : avar : bvar : ivar : fvars)-                    (sequence cxt) tp''-          genDecl n = [| In . $(varE $ mkName $ "inj" ++ show n) |]--deepInjectn :: Int -> Q [Dec]-deepInjectn n = do-  let i = mkName ("deepInject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar) : d-    where genSig fvars gvar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let cxt' = classP ''HDifunctor [tp]-            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar-            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
− src/Data/Comp/MultiParam/Derive/Ordering.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,-  ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.Ordering--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @OrdHD@.-------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.Ordering-    (-     OrdHD(..),-     makeOrdHD-    ) where--import Data.Comp.MultiParam.FreshM hiding (Name)-import Data.Comp.MultiParam.Ordering-import Data.Comp.Derive.Utils-import Data.Maybe-import Data.List-import Language.Haskell.TH hiding (Cxt)-import Control.Monad (liftM)--compList :: [Ordering] -> Ordering-compList = fromMaybe EQ . find (/= EQ)--{-| Derive an instance of 'OrdHD' for a type constructor of any parametric-  kind taking at least three arguments. -}-makeOrdHD :: Name -> Q [Dec]-makeOrdHD fname = do-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  let args' = init args-  -- covariant argument-  let coArg :: Name = tyVarBndrName $ last args'-  -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'-  let argNames = map (VarT . tyVarBndrName) (init $ init args')-  let complType = foldl AppT (ConT name) argNames-  let classType = AppT (ConT ''OrdHD) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  compareHDDecl <- funD 'compareHD (compareHDClauses conArg coArg constrs')-  let context = map (\arg -> ClassP ''Ord [arg]) argNames-  return [InstanceD context classType [compareHDDecl]]-      where compareHDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ]-            compareHDClauses _ _ [] = []-            compareHDClauses conArg coArg constrs = -                let constrs' = constrs `zip` [1..]-                    constPairs = [(x,y)| x<-constrs', y <- constrs']-                in map (genClause conArg coArg) constPairs-            genClause conArg coArg ((c,n),(d,m))-                | n == m = genEqClause conArg coArg c-                | n < m = genLtClause c d-                | otherwise = genGtClause c d-            genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            genEqClause conArg coArg (constr, args) = do -              varXs <- newNames (length args) "x"-              varYs <- newNames (length args) "y"-              let patX = ConP constr $ map VarP varXs-              let patY = ConP constr $ map VarP varYs-              body <- eqDBody conArg coArg (zip3 varXs varYs args)-              return $ Clause [patX, patY] (NormalB body) []-            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ-            eqDBody conArg coArg x =-                [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|]-            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ-            eqDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =-                    [| return $ compare $(varE x) $(varE y) |]-                | otherwise =-                    case tp of-                      AppT (VarT a) _ -                          | a == coArg -> [| pcompare $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (AppT (VarT a) _)) _-                          | a == conArg ->-                              [| withName (\v -> pcompare ($(varE x) $ nameCoerce v)-                                                          ($(varE y) $ nameCoerce v)) |]-                      SigT tp' _ ->-                          eqDB conArg coArg (x, y, tp')-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| compareHD $(varE x) $(varE y) |]-                          else-                              [| pcompare $(varE x) $(varE y) |]-            genLtClause (c, _) (d, _) =-                clause [recP c [], recP d []] (normalB [| return LT |]) []-            genGtClause (c, _) (d, _) =-                clause [recP c [], recP d []] (normalB [| return GT |]) []
− src/Data/Comp/MultiParam/Derive/Projections.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE TemplateHaskell, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.Projections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature projections.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.Projections-    (-     projn,-     projectn,-     deepProjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Control.Monad (liftM)-import Data.Comp.MultiParam.HDitraversable (HDitraversable)-import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.Algebra (appTSigFunM')-import Data.Comp.MultiParam.Ops ((:+:)(..), (:<:)(..))--projn :: Int -> Q [Dec]-projn n = do-  let p = mkName $ "proj" ++ show n-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let bvar = mkName "b"-  let ivar = mkName "i"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar bvar ivar) []]]-  sequence $ (sigD p $ genSig gvars avar bvar ivar) : d-    where genSig gvars avar bvar ivar = do-            let fvar = mkName "f"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = arrowT `appT` (varT fvar `appT` varT avar `appT`-                                     varT bvar `appT` varT ivar)-                             `appT` (conT ''Maybe `appT`-                                     (tp `appT` varT avar `appT`-                                      varT bvar `appT` varT ivar))-            forallT (map PlainTV $ fvar : avar : bvar : ivar : gvars)-                    (sequence cxt) tp'-          genDecl x [g] a b i =-            [| liftM inj (proj $(varE x)-                          :: Maybe ($(varT g `appT` varT a `appT`-                                      varT b `appT` varT i))) |]-          genDecl x (g:gs) a b i =-            [| case (proj $(varE x)-                         :: Maybe ($(varT g `appT` varT a `appT`-                                     varT b `appT` varT i))) of-                 Just y -> Just $ inj y-                 _ -> $(genDecl x gs a b i) |]-          genDecl _ _ _ _ _ = error "genDecl called with empty list"--projectn :: Int -> Q [Dec]-projectn n = do-  let p = mkName ("project" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let bvar = mkName "b"-  let ivar = mkName "i"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ (sigD p $ genSig gvars avar bvar ivar) : d-    where genSig gvars avar bvar ivar = do-            let fvar = mkName "f"-            let hvar = mkName "h"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar-                                 `appT` varT avar `appT` varT bvar-            let tp'' = arrowT `appT` (tp' `appT` varT ivar)-                              `appT` (conT ''Maybe `appT`-                                      (tp `appT` varT avar `appT` tp' `appT`-                                       varT ivar))-            forallT (map PlainTV $ hvar : fvar : avar : bvar : ivar : gvars)-                    (sequence cxt) tp''-          genDecl x n = [| case $(varE x) of-                             Hole _ -> Nothing-                             Var _ -> Nothing-                             In t -> $(varE $ mkName $ "proj" ++ show n) t |]--deepProjectn :: Int -> Q [Dec]-deepProjectn n = do-  let p = mkName ("deepProject" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let d = [funD p [clause [] (normalB $ genDecl n) []]]-  sequence $ (sigD p $ genSig gvars) : d-    where genSig gvars = do-            let fvar = mkName "f"-            let ivar = mkName "i"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let cxt' = classP ''HDitraversable [tp]-            let tp' = arrowT `appT` (conT ''Term `appT` varT fvar `appT` varT ivar)-                             `appT` (conT ''Maybe `appT` (conT ''Term `appT` tp `appT` varT ivar))-            forallT (map PlainTV $ fvar : ivar : gvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appTSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
− src/Data/Comp/MultiParam/Derive/Show.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,-  ScopedTypeVariables, UndecidableInstances, KindSignatures #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.Show--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @ShowHD@.-------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.Show-    (-     ShowHD(..),-     makeShowHD-    ) where--import Data.Comp.Derive.Utils-import Data.Comp.MultiParam.FreshM hiding (Name)-import qualified Data.Comp.MultiParam.FreshM as FreshM-import Data.Comp.MultiParam.HDifunctor-import Control.Monad-import Language.Haskell.TH hiding (Cxt, match)-import qualified Data.Traversable as T--{-| Signature printing. An instance @ShowHD f@ gives rise to an instance-  @Show (Term f i)@. -}-class ShowHD f where-    showHD :: f FreshM.Name (K (FreshM String)) i -> FreshM String--newtype Dummy = Dummy String--instance Show Dummy where-  show (Dummy s) = s--{-| Derive an instance of 'ShowHD' for a type constructor of any parametric-  kind taking at least three arguments. -}-makeShowHD :: Name -> Q [Dec]-makeShowHD fname = do-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  let args' = init args-  -- covariant argument-  let coArg :: Name = tyVarBndrName $ last args'-  -- contravariant argument-  let conArg :: Name = tyVarBndrName $ last $ init args'-  let argNames = map (VarT . tyVarBndrName) (init $ init args')-  let complType = foldl AppT (ConT name) argNames-  let classType = AppT (ConT ''ShowHD) complType-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  showHDDecl <- funD 'showHD (map (showHDClause conArg coArg) constrs')-  let context = map (\arg -> ClassP ''Show [arg]) argNames-  return [InstanceD context classType [showHDDecl]]-      where showHDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            showHDClause conArg coArg (constr, args) = do-              varXs <- newNames (length args) "x"-              -- Pattern for the constructor-              let patx = ConP constr $ map VarP varXs-              body <- showHDBody (nameBase constr) conArg coArg (zip varXs args)-              return $ Clause [patx] (NormalB body) []-            showHDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ-            showHDBody constr conArg coArg x =-                [|liftM (unwords . (constr :) .-                         map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x))-                        (sequence $(listE $ map (showHDB conArg coArg) x))|]-            showHDB :: Name -> Name -> (Name, Type) -> ExpQ-            showHDB conArg coArg (x, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =-                    [| return $ show $(varE x) |]-                | otherwise =-                    case tp of-                      AppT (VarT a) _ -                          | a == coArg -> [| unK $(varE x) |]-                      AppT (AppT ArrowT (AppT (VarT a) _)) _-                          | a == conArg ->-                              [| withName (\v -> do body <- (unK . $(varE x)) v-                                                    return $ "\\" ++ show v ++ " -> " ++ body) |]-                      SigT tp' _ ->-                          showHDB conArg coArg (x, tp')-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| showHD $(varE x) |]-                          else-                              [| liftM show $ T.mapM (liftM Dummy . unK) $(varE x) |]
− src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs 
@@ -1,48 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.SmartAConstructors--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive smart constructors with annotations for higher-order--- difunctors.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.SmartAConstructors -    (-     smartAConstructors-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Derive.Utils-import Data.Comp.MultiParam.Ops-import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.HDifunctor--import Control.Monad--{-| Derive smart constructors with annotations for a higher-order difunctor. The- smart constructors are similar to the ordinary constructors, but a- 'injectA . hdimap Var id' is automatically inserted. -}-smartAConstructors :: Name -> Q [Dec]-smartAConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname-    let cons = map abstractConType constrs-    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons-        where genSmartConstr targs tname (name, args) = do-                let bname = nameBase name-                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args-              genSmartConstr' targs tname sname name args = do-                varNs <- newNames args "x"-                varPr <- newName "_p"-                let pats = map varP (varPr : varNs)-                    vars = map varE varNs-                    val = appE [|injectA $(varE varPr)|] $-                          appE [|inj . hdimap Var id|] $ foldl appE (conE name) vars-                    function = [funD sname [clause pats (normalB [|In $val|]) []]]-                sequence function
− src/Data/Comp/MultiParam/Derive/SmartConstructors.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Derive.SmartConstructors--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive smart constructors for higher-order difunctors.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Derive.SmartConstructors -    (-     smartConstructors-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Derive.Utils-import Data.Comp.MultiParam.Sum-import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.HDifunctor-import Control.Arrow ((&&&))-import Control.Monad--{-| Derive smart constructors for a higher-order difunctor. The smart- constructors are similar to the ordinary constructors, but a- 'inject . hdimap Var id' is automatically inserted. -}-smartConstructors :: Name -> Q [Dec]-smartConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname-    let iVar = tyVarBndrName $ last targs-    let cons = map (abstractConType &&& iTp iVar) constrs-    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons-        where iTp iVar (ForallC _ cxt _) =-                  -- Check if the GADT phantom type is constrained-                  case [y | EqualP x y <- cxt, x == VarT iVar] of-                    [] -> Nothing-                    tp:_ -> Just tp-              iTp _ _ = Nothing-              genSmartConstr targs tname ((name, args), miTp) = do-                let bname = nameBase name-                genSmartConstr' targs tname (mkName $ 'i' : bname) name args miTp-              genSmartConstr' targs tname sname name args miTp = do-                varNs <- newNames args "x"-                let pats = map varP varNs-                    vars = map varE varNs-                    val = foldl appE (conE name) vars-                    sig = genSig targs tname sname args miTp-                    function = [funD sname [clause pats (normalB [|inject (hdimap Var id $val)|]) []]]-                sequence $ sig ++ function-              genSig targs tname sname 0 miTp = (:[]) $ do-                hvar <- newName "h"-                fvar <- newName "f"-                avar <- newName "a"-                bvar <- newName "b"-                ivar <- newName "i"-                let targs' = init $ init $ init targs-                    vars = hvar:fvar:avar:bvar:maybe [ivar] (const []) miTp++targs'-                    h = varT hvar-                    f = varT fvar-                    a = varT avar-                    b = varT bvar-                    i = varT ivar-                    ftype = foldl appT (conT tname) (map varT targs')-                    constr = classP ''(:<:) [ftype, f]-                    typ = foldl appT (conT ''Cxt) [h, f, a, b,maybe i return miTp]-                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ-                sigD sname typeSig-              genSig _ _ _ _ _ = []
− src/Data/Comp/MultiParam/Desugar.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,-  UndecidableInstances, OverlappingInstances, TypeOperators, Rank2Types #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Desugar--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This modules defines the 'Desugar' type class for desugaring of terms.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Desugar where--import Data.Comp.MultiParam---- |The desugaring term homomorphism.-class (HDifunctor f, HDifunctor g) => Desugar f g where-    desugHom :: Hom f g-    desugHom = desugHom' . hfmap Hole-    desugHom' :: f a (Cxt h g a b) :-> Cxt h g a b-    desugHom' x = appCxt (desugHom x)---- We make the lifting to sums explicit in order to make the Desugar--- class work with the default instance declaration further below.-instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where-    desugHom = caseHD desugHom desugHom----- |Desugar a term.-desugar :: Desugar f g => Term f :-> Term g-desugar (Term t) = Term (appHom desugHom t)---- |Lift desugaring to annotated terms.-desugarA :: (HDifunctor f', HDifunctor g', DistAnn f p f', DistAnn g p g',-             Desugar f g) => Term f' :-> Term g'-desugarA (Term t) = Term (appHom (propAnn desugHom) t)---- |Default desugaring instance.-instance (HDifunctor f, HDifunctor g, f :<: g) => Desugar f g where-    desugHom = simpCxt . inj
− src/Data/Comp/MultiParam/Equality.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,-  UndecidableInstances, IncoherentInstances, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Equality--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines equality for signatures, which lifts to equality for--- terms.-------------------------------------------------------------------------------------module Data.Comp.MultiParam.Equality-    (-     PEq(..),-     EqHD(..)-    ) where--import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.Sum-import Data.Comp.MultiParam.Ops-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.FreshM---- |Equality on parametric values. The equality test is performed inside the--- 'FreshM' monad for generating fresh identifiers.-class PEq a where-    peq :: a i -> a j -> FreshM Bool--instance Eq a => PEq (K a) where-    peq (K x) (K y) = return $ x == y--{-| Signature equality. An instance @EqHD f@ gives rise to an instance-  @Eq (Term f i)@. The equality test is performed inside the 'FreshM' monad for-  generating fresh identifiers. -}-class EqHD f where-    eqHD :: PEq a => f Name a i -> f Name a j -> FreshM Bool--{-| 'EqHD' is propagated through sums. -}-instance (EqHD f, EqHD g) => EqHD (f :+: g) where-    eqHD (Inl x) (Inl y) = eqHD x y-    eqHD (Inr x) (Inr y) = eqHD x y-    eqHD _ _ = return False--instance PEq Name where-   peq x y = return $ nameCoerce x == y--{-| From an 'EqHD' difunctor an 'Eq' instance of the corresponding term type can-  be derived. -}-instance EqHD f => EqHD (Cxt h f) where-    eqHD (In e1) (In e2) = eqHD e1 e2-    eqHD (Hole h1) (Hole h2) = peq h1 h2-    eqHD (Var p1) (Var p2) = peq p1 p2-    eqHD _ _ = return False--instance (EqHD f, PEq a) => PEq (Cxt h f Name a) where-    peq = eqHD--{-| Equality on terms. -}-instance (HDifunctor f, EqHD f) => Eq (Term f i) where-    (==) (Term x) (Term y) = evalFreshM $ eqHD x y
− src/Data/Comp/MultiParam/FreshM.hs 
@@ -1,54 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.FreshM--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines a monad for generating fresh, abstract names, useful--- e.g. for defining equality on terms.-------------------------------------------------------------------------------------module Data.Comp.MultiParam.FreshM-    (-     FreshM,-     Name,-     withName,-     nameCoerce,-     evalFreshM-    ) where--import Control.Monad.Reader---- |Monad for generating fresh (abstract) names.-newtype FreshM a = FreshM{unFreshM :: Reader Int a}-    deriving Monad---- |Abstract notion of a name (the constructor is hidden).-newtype Name i = Name Int-    deriving Eq--instance Show (Name i) where-    show (Name x) = names !! x-        where baseNames = ['a'..'z']-              names = map (:[]) baseNames ++ names' 1-              names' n = map (: show n) baseNames ++ names' (n + 1)--instance Ord (Name i) where-    compare (Name x) (Name y) = compare x y---- |Change the type tag of a name.-nameCoerce :: Name i -> Name j-nameCoerce (Name x) = Name x---- |Run the given computation with the next available name.-withName :: (Name i -> FreshM a) -> FreshM a-withName m = do name <- FreshM (asks Name)-                FreshM $ local ((+) 1) $ unFreshM $ m name---- |Evaluate a computation that uses fresh names.-evalFreshM :: FreshM a -> a-evalFreshM (FreshM m) = runReader m 0
− src/Data/Comp/MultiParam/HDifunctor.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Rank2Types,-  TypeOperators, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.HDifunctor--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines higher-order difunctors, a hybrid between higher-order--- functors (Johann, Ghani, POPL '08), and difunctors (Meijer, Hutton, FPCA--- '95). Higher-order difunctors are used to define signatures for--- compositional parametric generalised data types.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.HDifunctor-    (-     HDifunctor (..),-     HFunctor (..),-     I (..),-     K (..),-     E (..),-     A (..),-     (:->),-     NatM-    ) where--import Data.Comp.Multi.HFunctor---- | This class represents higher-order difunctors.-class HDifunctor f where-    hdimap :: (a :-> b) -> (c :-> d) -> f b c :-> f a d---- |A higher-order difunctor gives rise to a higher-order functor when--- restricted to a particular contravariant argument.-instance HDifunctor f => HFunctor (f a) where-    hfmap = hdimap id
− src/Data/Comp/MultiParam/HDitraversable.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses,-  FlexibleContexts, OverlappingInstances, TypeOperators, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.HDitraversable--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines traversable higher-order difunctors.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.HDitraversable-    (-     HDitraversable (..),-     HTraversable (..)-    ) where--import Prelude hiding (mapM, sequence, foldr)-import Data.Comp.Multi.HTraversable-import Data.Comp.MultiParam.HDifunctor--{-| HDifunctors representing data structures that can be traversed from left to-  right. -}-class HDifunctor f => HDitraversable f where-    hdimapM :: Monad m => NatM m b c -> NatM m (f a b) (f a c)
− src/Data/Comp/MultiParam/Ops.hs 
@@ -1,126 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies,-  FlexibleInstances, UndecidableInstances, IncoherentInstances,-  KindSignatures, RankNTypes #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Ops--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module provides operators on higher-order difunctors.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Ops where--import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.HDitraversable-import qualified Data.Comp.Ops as O-import Control.Monad (liftM)----- Sums-infixr 6 :+:---- |Formal sum of signatures (difunctors).-data (f :+: g) (a :: * -> *) (b :: * -> *) i = Inl (f a b i)-                                             | Inr (g a b i)--{-| Utility function to case on a higher-order difunctor sum, without exposing-  the internal representation of sums. -}-caseHD :: (f a b i -> c) -> (g a b i -> c) -> (f :+: g) a b i -> c-caseHD f g x = case x of-                 Inl x -> f x-                 Inr x -> g x--instance (HDifunctor f, HDifunctor g) => HDifunctor (f :+: g) where-    hdimap f g (Inl e) = Inl (hdimap f g e)-    hdimap f g (Inr e) = Inr (hdimap f g e)--instance (HDitraversable f, HDitraversable g) => HDitraversable (f :+: g) where-    hdimapM f (Inl e) = Inl `liftM` hdimapM f e-    hdimapM f (Inr e) = Inr `liftM` hdimapM f e---- | Signature containment relation for automatic injections. The left-hand must--- be an atomic signature, where as the right-hand side must have a list-like--- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@,--- non-examples include @f :+: g :<: f :+: (g :+: h)@ and--- @f :<: (f :+: g) :+: h@.-class (sub :: (* -> *) -> (* -> *) -> * -> *) :<: sup where-    inj :: sub a b :-> sup a b-    proj :: NatM Maybe (sup a b) (sub a b)--instance (:<:) f f where-    inj = id-    proj = Just--instance (:<:) f (f :+: g) where-    inj = Inl-    proj (Inl x) = Just x-    proj (Inr _) = Nothing--instance (f :<: g) => (:<:) f (h :+: g) where-    inj = Inr . inj-    proj (Inr x) = proj x-    proj (Inl _) = Nothing----- Products-infixr 8 :*:---- |Formal product of signatures (higher-order difunctors).-data (f :*: g) a b = f a b :*: g a b--ffst :: (f :*: g) a b -> f a b-ffst (x :*: _) = x--fsnd :: (f :*: g) a b -> g a b -fsnd (_ :*: x) = x----- Constant Products-infixr 7 :&:--{-| This data type adds a constant product to a signature. -}-data (f :&: p) (a :: * -> *) (b :: * -> *) i = f a b i :&: p--instance HDifunctor f => HDifunctor (f :&: p) where-    hdimap f g (v :&: c) = hdimap f g v :&: c--instance HDitraversable f => HDitraversable (f :&: p) where-    hdimapM f (v :&: c) = liftM (:&: c) (hdimapM f v)--{-| This class defines how to distribute an annotation over a sum of-  signatures. -}-class DistAnn (s :: (* -> *) -> (* -> *) -> * -> *) p s' | s' -> s, s' -> p where-    {-| Inject an annotation over a signature. -}-    injectA :: p -> s a b :-> s' a b-    {-| Project an annotation from a signature. -}-    projectA :: s' a b :-> (s a b O.:&: p)--class RemA (s :: (* -> *) -> (* -> *) -> * -> *) s' | s -> s' where-    {-| Remove annotations from a signature. -}-    remA :: s a b :-> s' a b--instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where-    remA (Inl (v :&: _)) = Inl v-    remA (Inr v) = Inr $ remA v--instance RemA (f :&: p) f where-    remA (v :&: _) = v--instance DistAnn f p (f :&: p) where-    injectA c v = v :&: c--    projectA (v :&: p) = v O.:&: p--instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where-    injectA c (Inl v) = Inl (v :&: c)-    injectA c (Inr v) = Inr $ injectA c v--    projectA (Inl (v :&: p)) = Inl v O.:&: p-    projectA (Inr v) = let (v' O.:&: p) = projectA v-                       in Inr v' O.:&: p
− src/Data/Comp/MultiParam/Ordering.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,-  UndecidableInstances, IncoherentInstances, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Ordering--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines ordering of signatures, which lifts to ordering of--- terms and contexts.-------------------------------------------------------------------------------------module Data.Comp.MultiParam.Ordering-    (-     POrd(..),-     OrdHD(..)-    ) where--import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.Sum-import Data.Comp.MultiParam.Ops-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.FreshM-import Data.Comp.MultiParam.Equality---- |Ordering of parametric values.-class PEq a => POrd a where-    pcompare :: a i -> a j -> FreshM Ordering--instance Ord a => POrd (K a) where-    pcompare (K x) (K y) = return $ compare x y--{-| Signature ordering. An instance @OrdHD f@ gives rise to an instance-  @Ord (Term f)@. -}-class EqHD f => OrdHD f where-    compareHD :: POrd a => f Name a i -> f Name a j -> FreshM Ordering--{-| 'OrdHD' is propagated through sums. -}-instance (OrdHD f, OrdHD g) => OrdHD (f :+: g) where-    compareHD (Inl x) (Inl y) = compareHD x y-    compareHD (Inl _) (Inr _) = return LT-    compareHD (Inr x) (Inr y) = compareHD x y-    compareHD (Inr _) (Inl _) = return GT--{-| From an 'OrdHD' difunctor an 'Ord' instance of the corresponding term type-  can be derived. -}-instance OrdHD f => OrdHD (Cxt h f) where-    compareHD (In e1) (In e2) = compareHD e1 e2-    compareHD (Hole h1) (Hole h2) = pcompare h1 h2-    compareHD (Var p1) (Var p2) = pcompare p1 p2-    compareHD (In _) _ = return LT-    compareHD (Hole _) (In _) = return GT-    compareHD (Hole _) (Var _) = return LT-    compareHD (Var _) _ = return GT--instance POrd Name where-    pcompare x y = return $ compare (nameCoerce x) y--instance (OrdHD f, POrd a) => POrd (Cxt h f Name a) where-    pcompare = compareHD--{-| Ordering of terms. -}-instance (HDifunctor f, OrdHD f) => Ord (Term f i) where-    compare (Term x) (Term y) = evalFreshM $ compareHD x y
− src/Data/Comp/MultiParam/Show.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances,-  IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Show--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines showing of signatures, which lifts to showing of terms.-------------------------------------------------------------------------------------module Data.Comp.MultiParam.Show-    (-     ShowHD(..)-    ) where--import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.Ops-import Data.Comp.MultiParam.Derive-import Data.Comp.MultiParam.FreshM---- Lift ShowHD to sums-$(derive [liftSum] [''ShowHD])--{-| From an 'ShowHD' higher-order difunctor an 'ShowHD' instance of the-  corresponding term type can be derived. -}-instance (HDifunctor f, ShowHD f) => ShowHD (Cxt h f) where-    showHD (In t) = showHD $ hfmap (K . showHD) t-    showHD (Hole h) = unK h-    showHD (Var p) = return $ show p--{-| Printing of terms. -}-instance (HDifunctor f, ShowHD f) => Show (Term f i) where-    show = evalFreshM . showHD . toCxt . unTerm--instance (ShowHD f, Show p) => ShowHD (f :&: p) where-    showHD (x :&: p) = do sx <- showHD x-                          return $ sx ++ " :&: " ++ show p
− src/Data/Comp/MultiParam/Sum.hs 
@@ -1,180 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,-  FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,-  ScopedTypeVariables, TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Sum--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module provides the infrastructure to extend signatures.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Sum-    (-     (:<:),-     (:+:),-     caseHD,--     -- * Projections for Signatures and Terms-     proj,-     proj2,-     proj3,-     proj4,-     proj5,-     proj6,-     proj7,-     proj8,-     proj9,-     proj10,-     project,-     project2,-     project3,-     project4,-     project5,-     project6,-     project7,-     project8,-     project9,-     project10,-     deepProject,-     deepProject2,-     deepProject3,-     deepProject4,-     deepProject5,-     deepProject6,-     deepProject7,-     deepProject8,-     deepProject9,-     deepProject10,--     -- * Injections for Signatures and Terms-     inj,-     inj2,-     inj3,-     inj4,-     inj5,-     inj6,-     inj7,-     inj8,-     inj9,-     inj10,-     inject,-     inject2,-     inject3,-     inject4,-     inject5,-     inject6,-     inject7,-     inject8,-     inject9,-     inject10,-     deepInject,-     deepInject2,-     deepInject3,-     deepInject4,-     deepInject5,-     deepInject6,-     deepInject7,-     deepInject8,-     deepInject9,-     deepInject10,--     injectCxt,-     liftCxt-    ) where--import Prelude hiding (sequence)-import Control.Monad hiding (sequence)-import Data.Comp.MultiParam.Term-import Data.Comp.MultiParam.Algebra-import Data.Comp.MultiParam.Ops-import Data.Comp.MultiParam.Derive.Projections-import Data.Comp.MultiParam.Derive.Injections-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.HDitraversable--$(liftM concat $ mapM projn [2..10])---- |Project the outermost layer of a term to a sub signature. If the signature--- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.-project :: (g :<: f) => NatM Maybe (Cxt h f a b) (g a (Cxt h f a b))-project (In t)   = proj t-project (Hole _) = Nothing-project (Var _)  = Nothing--$(liftM concat $ mapM projectn [2..10])---- | Tries to coerce a term/context to a term/context over a sub-signature. If--- the signature @g@ is compound of /n/ atomic signatures, use--- @deepProject@/n/ instead.-deepProject :: (HDitraversable g, g :<: f) => Term f i -> Maybe (Term g i)-{-# INLINE deepProject #-}-deepProject = appTSigFunM' proj--$(liftM concat $ mapM deepProjectn [2..10])-{-# INLINE deepProject2 #-}-{-# INLINE deepProject3 #-}-{-# INLINE deepProject4 #-}-{-# INLINE deepProject5 #-}-{-# INLINE deepProject6 #-}-{-# INLINE deepProject7 #-}-{-# INLINE deepProject8 #-}-{-# INLINE deepProject9 #-}-{-# INLINE deepProject10 #-}--$(liftM concat $ mapM injn [2..10])---- |Inject a term where the outermost layer is a sub signature. If the signature--- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.-inject :: (g :<: f) => g a (Cxt h f a b) :-> Cxt h f a b-inject = In . inj--$(liftM concat $ mapM injectn [2..10])---- |Inject a term over a sub signature to a term over larger signature. If the--- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/--- instead.-deepInject :: (HDifunctor g, g :<: f) => CxtFun g f-{-# INLINE deepInject #-}-deepInject = appSigFun inj--$(liftM concat $ mapM deepInjectn [2..10])-{-# INLINE deepInject2 #-}-{-# INLINE deepInject3 #-}-{-# INLINE deepInject4 #-}-{-# INLINE deepInject5 #-}-{-# INLINE deepInject6 #-}-{-# INLINE deepInject7 #-}-{-# INLINE deepInject8 #-}-{-# INLINE deepInject9 #-}-{-# INLINE deepInject10 #-}--{-| This function injects a whole context into another context. -}-injectCxt :: (HDifunctor g, g :<: f) => Cxt h g a (Cxt h f a b) :-> Cxt h f a b-injectCxt (In t) = inject $ hfmap injectCxt t-injectCxt (Hole x) = x-injectCxt (Var p) = Var p--{-| This function lifts the given functor to a context. -}-liftCxt :: (HDifunctor f, g :<: f) => g a b :-> Cxt Hole f a b-liftCxt g = simpCxt $ inj g--instance (Show (f a b i), Show (g a b i)) => Show ((f :+: g) a b i) where-    show (Inl v) = show v-    show (Inr v) = show v--instance (Ord (f a b i), Ord (g a b i)) => Ord ((f :+: g) a b i) where-    compare (Inl _) (Inr _) = LT-    compare (Inr _) (Inl _) = GT-    compare (Inl x) (Inl y) = compare x y-    compare (Inr x) (Inr y) = compare x y--instance (Eq (f a b i), Eq (g a b i)) => Eq ((f :+: g) a b i) where-    (Inl x) == (Inl y) = x == y-    (Inr x) == (Inr y) = x == y                   -    _ == _ = False
− src/Data/Comp/MultiParam/Term.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, Rank2Types,-  MultiParamTypeClasses, TypeOperators, ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.MultiParam.Term--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines the central notion of /generalised parametrised terms/--- and their generalisation to generalised parametrised contexts.--------------------------------------------------------------------------------------module Data.Comp.MultiParam.Term-    (-     Cxt(..),-     Hole,-     NoHole,-     Term(..),-     Trm,-     Context,-     simpCxt,-     toCxt,-     hfmapCxt,-     hdimapMCxt,-     ParamFunctor (..)-    ) where--import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)-import Data.Comp.MultiParam.HDifunctor-import Data.Comp.MultiParam.HDitraversable-import Control.Monad -import Unsafe.Coerce-import Data.Maybe (fromJust)--{-| This data type represents contexts over a signature. Contexts are terms-  containing zero or more holes, and zero or more parameters. The first-  parameter is a phantom type indicating whether the context has holes. The-  second paramater is the signature of the context, in the form of a-  "Data.Comp.MultiParam.HDifunctor". The third parameter is the type of-  parameters, the fourth parameter is the type of holes, and the fifth-  parameter is the GADT type. -}-data Cxt :: * -> ((* -> *) -> (* -> *) -> * -> *) -> (* -> *) -> (* -> *) -> * -> * where-            In :: f a (Cxt h f a b) i -> Cxt h f a b i-            Hole :: b i -> Cxt Hole f a b i-            Var :: a i -> Cxt h f a b i--{-| Phantom type used to define 'Context'. -}-data Hole--{-| Phantom type used to define 'Term'. -}-data NoHole--{-| A context may contain holes. -}-type Context = Cxt Hole--{-| \"Preterms\" |-}-type Trm f a = Cxt NoHole f a (K ())--{-| A term is a context with no holes, where all occurrences of the-  contravariant parameter is fully parametric. -}-newtype Term f i = Term{unTerm :: forall a. Trm f a i}--{-| Convert a difunctorial value into a context. -}-simpCxt :: HDifunctor f => f a b :-> Cxt Hole f a b-{-# INLINE simpCxt #-}-simpCxt = In . hfmap Hole--toCxt :: HDifunctor f => Trm f a :-> Cxt h f a b-{-# INLINE toCxt #-}-toCxt = unsafeCoerce---- | This is an instance of 'hfmap' for 'Cxt'.-hfmapCxt :: forall h f a b b'. HDifunctor f-         => (b :-> b') -> Cxt h f a b :-> Cxt h f a b'-hfmapCxt f = run-    where run :: Cxt h f a b :-> Cxt h f a b'-          run (In t)   = In $ hfmap run t-          run (Var a)  = Var a-          run (Hole b) = Hole $ f b---- | This is an instance of 'hdimapM' for 'Cxt'.-hdimapMCxt :: forall h f a b b' m . (HDitraversable f, Monad m)-          => NatM m b b' -> NatM m (Cxt h f a b) (Cxt h f a b')-hdimapMCxt f = run-    where run :: NatM m (Cxt h f a b) (Cxt h f a b')-          run (In t)   = liftM In $ hdimapM run t-          run (Var a)  = return $ Var a-          run (Hole b) = liftM Hole (f b)-          -          -          -{-| Monads for which embedded @Trm@ values, which are parametric at top level,-  can be made into monadic @Term@ values, i.e. \"pushing the parametricity-  inwards\". -}-class ParamFunctor m where-    termM :: (forall a. m (Trm f a i)) -> m (Term f i)--coerceTermM :: ParamFunctor m => (forall a. m (Trm f a i)) -> m (Term f i)-{-# INLINE coerceTermM #-}-coerceTermM t = unsafeCoerce t--{-# RULES-    "termM/coerce'" termM = coerceTermM- #-}--instance ParamFunctor Maybe where-    termM Nothing = Nothing-    termM x       = Just (Term $ fromJust x)--instance ParamFunctor (Either a) where-    termM (Left x) = Left x-    termM x        = Right (Term $ fromRight x)-                             where fromRight :: Either a b -> b-                                   fromRight (Right x) = x-                                   fromRight _ = error "fromRight: Left"--instance ParamFunctor [] where-    termM [] = []-    termM l  = Term (head l) : termM (tail l)
− src/Data/Comp/Number.hs 
@@ -1,45 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Number--- Copyright   :  (c) 2012 Patrick Bahr--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)--- --- This module provides functionality to number the components of a--- functorial value with consecutive integers.--------------------------------------------------------------------------------------module Data.Comp.Number -    ( Numbered (..)-    , unNumbered-    , number-    , Traversable ()) where--import Data.Traversable--import Control.Monad.State hiding (mapM)-import Prelude hiding (mapM)----- | This type is used for numbering components of a functorial value.-newtype Numbered a = Numbered (Int, a)--unNumbered :: Numbered a -> a-unNumbered (Numbered (_, x)) = x--instance Eq (Numbered a) where-    Numbered (i,_) == Numbered (j,_) = i == j--instance Ord (Numbered a) where-    compare (Numbered (i,_))  (Numbered (j,_)) = i `compare` j---- | This function numbers the components of the given functorial--- value with consecutive integers starting at 0.-number :: Traversable f => f a -> f (Numbered a)-number x = fst $ runState (mapM run x) 0 where-  run b = do n <- get-             put (n+1)-             return $ Numbered (n,b)
src/Data/Comp/Ops.hs view
@@ -1,6 +1,16 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,-             FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,-             ScopedTypeVariables, FunctionalDependencies, UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE TypeSynonymInstances   #-}+{-# LANGUAGE UndecidableInstances   #-}  -------------------------------------------------------------------------------- -- |@@ -19,13 +29,16 @@  import Data.Foldable import Data.Traversable+import Data.Kind  import Control.Applicative-import Control.Monad hiding (sequence, mapM)+import Control.Monad hiding (mapM, sequence)+import Data.Comp.SubsumeCommon -import Prelude hiding (foldl, mapM, sequence, foldl1, foldr1, foldr) +import Prelude hiding (foldl, foldl1, foldr, foldr1, mapM, sequence) + -- Sums  infixr 6 :+:@@ -35,6 +48,12 @@ data (f :+: g) e = Inl (f e)                  | Inr (g e) +fromInl :: (f :+: g) e -> Maybe (f e)+fromInl = caseF Just (const Nothing)++fromInr :: (f :+: g) e -> Maybe (g e)+fromInr = caseF (const Nothing) Just+ {-| Utility function to case on a functor sum, without exposing the internal   representation of sums. -} caseF :: (f a -> b) -> (g a -> b) -> (f :+: g) a -> b@@ -71,29 +90,70 @@     sequence (Inl e) = Inl `liftM` sequence e     sequence (Inr e) = Inr `liftM` sequence e --- | Signature containment relation for automatic injections. The left-hand must--- be an atomic signature, where as the right-hand side must have a list-like--- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@,--- non-examples include @f :+: g :<: f :+: (g :+: h)@ and--- @f :<: (f :+: g) :+: h@.-class sub :<: sup where-  inj :: sub a -> sup a-  proj :: sup a -> Maybe (sub a)+infixl 5 :<:+infixl 5 :=: -instance (:<:) f f where-    inj = id-    proj = Just+type family Elem (f :: Type -> Type) (g :: Type -> Type) :: Emb where+    Elem f f = Found Here+    Elem (f1 :+: f2) g =  Sum' (Elem f1 g) (Elem f2 g)+    Elem f (g1 :+: g2) = Choose (Elem f g1) (Elem f g2)+    Elem f g = NotFound -instance (:<:) f (f :+: g) where-    inj = Inl-    proj (Inl x) = Just x-    proj (Inr _) = Nothing+class Subsume (e :: Emb) (f :: Type -> Type) (g :: Type -> Type) where+  inj'  :: Proxy e -> f a -> g a+  prj'  :: Proxy e -> g a -> Maybe (f a) -instance (f :<: g) => (:<:) f (h :+: g) where-    inj = Inr . inj-    proj (Inr x) = proj x-    proj (Inl _) = Nothing+instance Subsume (Found Here) f f where+    inj' _ = id +    prj' _ = Just++instance Subsume (Found p) f g => Subsume (Found (Le p)) f (g :+: g') where+    inj' _ = Inl . inj' (P :: Proxy (Found p))++    prj' _ (Inl x) = prj' (P :: Proxy (Found p)) x+    prj' _ _       = Nothing++instance Subsume (Found p) f g => Subsume (Found (Ri p)) f (g' :+: g) where+    inj' _ = Inr . inj' (P :: Proxy (Found p))++    prj' _ (Inr x) = prj' (P :: Proxy (Found p)) x+    prj' _ _       = Nothing++instance (Subsume (Found p1) f1 g, Subsume (Found p2) f2 g)+    => Subsume (Found (Sum p1 p2)) (f1 :+: f2) g where+    inj' _ (Inl x) = inj' (P :: Proxy (Found p1)) x+    inj' _ (Inr x) = inj' (P :: Proxy (Found p2)) x++    prj' _ x = case prj' (P :: Proxy (Found p1)) x of+                 Just y -> Just (Inl y)+                 _      -> case prj' (P :: Proxy (Found p2)) x of+                             Just y -> Just (Inr y)+                             _      -> Nothing++++-- | A constraint @f :<: g@ expresses that the signature @f@ is+-- subsumed by @g@, i.e. @f@ can be used to construct elements in @g@.+type f :<: g = (Subsume (ComprEmb (Elem f g)) f g)++inj :: forall f g a . (f :<: g) => f a -> g a+inj = inj' (P :: Proxy (ComprEmb (Elem f g)))++proj :: forall f g a . (f :<: g) => g a -> Maybe (f a)+proj = prj' (P :: Proxy (ComprEmb (Elem f g)))++type f :=: g = (f :<: g, g :<: f)++++spl :: (f :=: f1 :+: f2) => (f1 a -> b) -> (f2 a -> b) -> f a -> b+spl f1 f2 x = case inj x of+            Inl y -> f1 y+            Inr y -> f2 y+++ -- Products  infixr 8 :*:@@ -107,6 +167,21 @@  fsnd :: (f :*: g) a -> g a fsnd (_ :*: x) = x++instance (Functor f, Functor g) => Functor (f :*: g) where+    fmap h (f :*: g) = (fmap h f :*: fmap h g)+++instance (Foldable f, Foldable g) => Foldable (f :*: g) where+    foldr f e (x :*: y) = foldr f (foldr f e y) x+    foldl f e (x :*: y) = foldl f (foldl f e x) y+++instance (Traversable f, Traversable g) => Traversable (f :*: g) where+    traverse f (x :*: y) = liftA2 (:*:) (traverse f x) (traverse f y)+    sequenceA (x :*: y) = liftA2 (:*:)(sequenceA x) (sequenceA y)+    mapM f (x :*: y) = liftM2 (:*:) (mapM f x) (mapM f y)+    sequence (x :*: y) = liftM2 (:*:) (sequence x) (sequence y)  -- Constant Products
src/Data/Comp/Ordering.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators   #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Ordering@@ -17,12 +19,11 @@      OrdF(..)     ) where -import Data.Comp.Term-import Data.Comp.Sum-import Data.Comp.Ops-import Data.Comp.Equality () import Data.Comp.Derive import Data.Comp.Derive.Utils+import Data.Comp.Equality ()+import Data.Comp.Ops+import Data.Comp.Term  {-|   From an 'OrdF' functor an 'Ord' instance of the corresponding@@ -38,7 +39,7 @@     compareF Hole{} Term{} = GT  -- instance (OrdF f, Ord p) => OrdF (f :*: p) where---     compareF (v1 :*: p1) (v2 :*: p2) = +--     compareF (v1 :*: p1) (v2 :*: p2) = --         case compareF v1 v2 of --           EQ ->  compare p1 p2 --           res -> res
− src/Data/Comp/Param.hs 
@@ -1,32 +0,0 @@------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines the infrastructure necessary to use--- /Parametric Compositional Data Types/. Parametric Compositional Data Types --- is an extension of Compositional Data Types with parametric--- higher-order abstract syntax (PHOAS) for usage with binders. Examples of--- usage are bundled with the package in the library--- @examples\/Examples\/Param@.-------------------------------------------------------------------------------------module Data.Comp.Param (-    module Data.Comp.Param.Term-  , module Data.Comp.Param.Algebra-  , module Data.Comp.Param.Difunctor-  , module Data.Comp.Param.Sum-  , module Data.Comp.Param.Annotation-  , module Data.Comp.Param.Equality-    ) where--import Data.Comp.Param.Term-import Data.Comp.Param.Algebra-import Data.Comp.Param.Difunctor-import Data.Comp.Param.Sum-import Data.Comp.Param.Annotation-import Data.Comp.Param.Equality
− src/Data/Comp/Param/Algebra.hs 
@@ -1,964 +0,0 @@-{-# LANGUAGE GADTs, Rank2Types, ScopedTypeVariables, TypeOperators,-  FlexibleContexts, CPP #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Algebra--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines the notion of algebras and catamorphisms, and their--- generalizations to e.g. monadic versions and other (co)recursion schemes.--------------------------------------------------------------------------------------module Data.Comp.Param.Algebra (-      -- * Algebras & Catamorphisms-      Alg,-      free,-      cata,-      cata',-      appCxt,-      -      -- * Monadic Algebras & Catamorphisms-      AlgM,-      algM,-      freeM,-      cataM,-      cataM',--      -- * Term Homomorphisms-      CxtFun,-      SigFun,-      Hom,-      appHom,-      appHom',-      compHom,-      appSigFun,-      appSigFun',-      compSigFun,-      compHomSigFun,-      compSigFunHom,-      hom,-      compAlg,-      compAlgSigFun,--      -- * Monadic Term Homomorphisms-      CxtFunM,-      SigFunM,-      HomM,-      SigFunMD,-      HomMD,-      sigFunM,-      appHomM,-      appTHomM,-      appHomM',-      appTHomM',-      homM,-      homMD,-      appSigFunM,-      appTSigFunM,-      appSigFunM',-      appTSigFunM',-      appSigFunMD,-      appTSigFunMD,-      compHomM,-      compHomM',-      compSigFunM,-      compSigFunHomM,-      compSigFunHomM',-      compAlgSigFunM,-      compAlgSigFunM',-      compAlgM,-      compAlgM',--      -- * Coalgebras & Anamorphisms-      Coalg,-      ana,-      CoalgM,-      anaM,--      -- * R-Algebras & Paramorphisms-      RAlg,-      para,-      RAlgM,-      paraM,--      -- * R-Coalgebras & Apomorphisms-      RCoalg,-      apo,-      RCoalgM,-      apoM,--      -- * CV-Algebras & Histomorphisms-      CVAlg,-      histo,-      CVAlgM,-      histoM,--      -- * CV-Coalgebras & Futumorphisms-      CVCoalg,-      futu,-      CVCoalg',-      futu',-      CVCoalgM,-      futuM-    ) where--import Prelude hiding (sequence, mapM)-import Control.Monad hiding (sequence, mapM)-import Data.Comp.Param.Term-import Data.Comp.Param.Ops-import Data.Comp.Param.Difunctor-import Data.Comp.Param.Ditraversable--{-| This type represents an algebra over a difunctor @f@ and carrier @a@. -}-type Alg f a = f a a -> a---{-| Construct a catamorphism for contexts over @f@ with holes of type @b@, from-  the given algebra. -}-free :: forall h f a b. Difunctor f-        => Alg f a -> (b -> a) -> Cxt h f a b -> a-free f g = run-    where run :: Cxt h f a b -> a-          run (In t) = f (difmap run t)-          run (Hole x) = g x-          run (Var p) = p--{-| Construct a catamorphism from the given algebra. -}-cata :: forall f a. Difunctor f => Alg f a -> Term f -> a -{-# NOINLINE [1] cata #-}-cata f (Term t) = run t-    where run :: Trm f a -> a-          run (In t) = f (difmap run t)-          run (Var x) = x--{-| A generalisation of 'cata' from terms over @f@ to contexts over @f@, where-  the holes have the type of the algebra carrier. -}-cata' :: Difunctor f => Alg f a -> Cxt h f a a -> a-{-# INLINE cata' #-}-cata' f = free f id--{-| This function applies a whole context into another context. -}-appCxt :: Difunctor f => Context f a (Cxt h f a b) -> Cxt h f a b-appCxt (In t) = In (difmap appCxt t)-appCxt (Hole x) = x-appCxt (Var p) = Var p--{-| This type represents a monadic algebra. It is similar to 'Alg' but-  the return type is monadic. -}-type AlgM m f a = f a a -> m a--{-| Convert a monadic algebra into an ordinary algebra with a monadic-  carrier. -}-algM :: (Ditraversable f, Monad m) => AlgM m f a -> Alg f (m a)-algM f x = disequence (dimap return id x) >>= f--{-| Construct a monadic catamorphism for contexts over @f@ with holes of type-  @b@, from the given monadic algebra. -}-freeM :: forall m h f a b. (Ditraversable f, Monad m)-         => AlgM m f a -> (b -> m a) -> Cxt h f a b -> m a-freeM f g = run-    where run :: Cxt h f a b -> m a-          run (In t) = f =<< dimapM run t-          run (Hole x) = g x-          run (Var p) = return p--{-| Construct a monadic catamorphism from the given monadic algebra. -}-cataM :: forall m f a. (Ditraversable f, Monad m) => AlgM m f a -> Term f -> m a-{-# NOINLINE [1] cataM #-}-cataM algm (Term t) = run t-    where run :: Trm f a  -> m a-          run (In t) = algm =<< dimapM run t-          run (Var x) = return x--{-| A generalisation of 'cataM' from terms over @f@ to contexts over @f@, where-  the holes have the type of the monadic algebra carrier. -}-cataM' :: forall m h f a. (Ditraversable f, Monad m)-          => AlgM m f a -> Cxt h f a (m a) -> m a-{-# NOINLINE [1] cataM' #-}-cataM' f = freeM f id--{-| This type represents a context function. -}-type CxtFun f g = forall h a b. Cxt h f a b -> Cxt h g a b---{-| This type represents a signature function. -}-type SigFun f g = forall a b. f a b -> g a b--{-| This type represents a term homomorphism. -}-type Hom f g = SigFun f (Context g)--{-| Apply a term homomorphism recursively to a term/context. -}-appHom :: forall f g. (Difunctor f, Difunctor g) => Hom f g -> CxtFun f g-{-# NOINLINE [1] appHom #-}-appHom f = run where-    run :: CxtFun f g-    run (In t) = appCxt (f (difmap run t))-    run (Hole x) = Hole x-    run (Var p) = Var p--{-| Apply a term homomorphism recursively to a term/context. -}-appHom' :: forall f g. (Difunctor g) => Hom f g -> CxtFun f g-{-# NOINLINE [1] appHom' #-}-appHom' f = run where-    run :: CxtFun f g-    run (In t) = appCxt (fmapCxt run (f t))-    run (Hole x) = Hole x-    run (Var p) = Var p--fmapCxt :: Difunctor f => (b -> b') -> Cxt h f a b -> Cxt h f a b'-fmapCxt f = run-    where run (In t) = In $ difmap run t-          run (Var a) = Var a-          run (Hole b)  = Hole $ f b--{-| Compose two term homomorphisms. -}-compHom :: (Difunctor g, Difunctor h)-               => Hom g h -> Hom f g -> Hom f h-compHom f g = appHom f . g---{-| Compose an algebra with a term homomorphism to get a new algebra. -}-compAlg :: (Difunctor f, Difunctor g) => Alg g a -> Hom f g -> Alg f a-compAlg alg talg = cata' alg . talg--compAlgSigFun  :: Alg g a -> SigFun f g -> Alg f a-compAlgSigFun alg sig = alg . sig---{-| This function applies a signature function to the given context. -}-appSigFun :: forall f g. (Difunctor f) => SigFun f g -> CxtFun f g-{-# NOINLINE [1] appSigFun #-}-appSigFun f = run-    where run (In t) = In $ f $ difmap run t-          run (Var x) = Var x-          run (Hole x) = Hole x--- implementation via term homomorphisms---  appSigFun f = appHom $ hom f----- | This function applies a signature function to the given--- context. This is a top-bottom variant of 'appSigFun'.-appSigFun' :: forall f g. (Difunctor g) => SigFun f g -> CxtFun f g-{-# NOINLINE [1] appSigFun' #-}-appSigFun' f = run-    where run (In t) = In $ difmap run $ f t-          run (Var x) = Var x-          run (Hole x) = Hole x--{-| This function composes two signature functions. -}-compSigFun :: SigFun g h -> SigFun f g -> SigFun f h-compSigFun f g = f . g--{-| This function composes a term homomorphism and a signature function. -}-compHomSigFun :: Hom g h -> SigFun f g -> Hom f h-compHomSigFun f g = f . g--{-| This function composes a term homomorphism and a signature function. -}-compSigFunHom :: (Difunctor g) => SigFun g h -> Hom f g -> Hom f h-compSigFunHom f g = appSigFun f . g---{-| Lifts the given signature function to the canonical term homomorphism. -}-hom :: Difunctor g => SigFun f g -> Hom f g-hom f = simpCxt . f--{-| This type represents a monadic signature function. -}-type SigFunM m f g = forall a b. f a b -> m (g a b)--{-| This type represents a monadic context function. -}-type CxtFunM m f g = forall h . SigFunM m (Cxt h f) (Cxt h g)--{-| This type represents a monadic signature function. It is similar to-  'SigFunM' but has monadic values also in the domain. -}-type SigFunMD m f g = forall a b. f a (m b) -> m (g a b)--{-| This type represents a monadic term homomorphism. -}-type HomM m f g = SigFunM m f (Context g)--{-| This type represents a monadic term homomorphism. It is similar to-  'HomM' but has monadic values also in the domain. -}-type HomMD m f g = SigFunMD m f (Context g)--{-| Lift the given signature function to a monadic signature function. Note that-  term homomorphisms are instances of signature functions. Hence this function-  also applies to term homomorphisms. -}-sigFunM :: Monad m => SigFun f g -> SigFunM m f g-sigFunM f = return . f--{-| Lift the given signature function to a monadic term homomorphism. -}-homM :: (Difunctor g, Monad m) => SigFunM m f g -> HomM m f g-homM f = liftM simpCxt . f---- | Apply a monadic term homomorphism recursively to a--- term/context. The monad is sequenced bottom-up.-appHomM :: forall f g m. (Ditraversable f, Difunctor g, Monad m)-           => HomM m f g -> CxtFunM m f g-{-# NOINLINE [1] appHomM #-}-appHomM f = run-    where run :: CxtFunM m f g-          run (In t) = liftM appCxt . f =<< dimapM run t-          run (Hole x) = return (Hole x)-          run (Var p) = return (Var p)--{-| A restricted form of |appHomM| which only works for terms. -}-appTHomM :: (Ditraversable f, ParamFunctor m, Monad m, Difunctor g)-            => HomM m f g -> Term f -> m (Term g)-appTHomM f (Term t) = termM (appHomM f t)----- | Apply a monadic term homomorphism recursively to a--- term/context. The monad is sequence top-down.-appHomM' :: forall f g m. (Ditraversable g, Monad m)-            => HomM m f g -> CxtFunM m f g-appHomM' f = run-    where run :: CxtFunM m f g-          run (In t)  = liftM appCxt . dimapMCxt run =<< f t-          run (Var p) = return (Var p)-          run (Hole x) = return (Hole x)--dimapMCxt :: (Ditraversable f, Monad m)-             => (b -> m b') -> Cxt h f a b -> m (Cxt h f a b')-dimapMCxt f = run-              where run (In t) = liftM In $ dimapM run t-                    run (Var a)  = return $ Var a-                    run (Hole b) = liftM Hole (f b)--{-| A restricted form of |appHomM'| which only works for terms. -}-appTHomM' :: (Ditraversable g, ParamFunctor m, Monad m, Difunctor g)-             => HomM m f g -> Term f -> m (Term g)-appTHomM' f (Term t) = termM (appHomM' f t)-            --{-| This function constructs the unique monadic homomorphism from the-  initial term algebra to the given term algebra. -}-homMD :: forall f g m. (Difunctor f, Difunctor g, Monad m)-         => HomMD m f g -> CxtFunM m f g-homMD f = run -    where run :: CxtFunM m f g-          run (In t) = liftM appCxt (f (difmap run t))-          run (Hole x) = return (Hole x)-          run (Var p) = return (Var p)--{-| This function applies a monadic signature function to the given context. -}-appSigFunM :: forall m f g. (Ditraversable f, Monad m)-              => SigFunM m f g -> CxtFunM m f g-appSigFunM f = run-    where run :: CxtFunM m f g-          run (In t) = liftM In . f =<< dimapM run t-          run (Var x) = return $ Var x-          run (Hole x) = return $ Hole x--- implementation via term homomorphisms---  appSigFunM f = appHomM $ hom' f--{-| A restricted form of |appSigFunM| which only works for terms. -}-appTSigFunM :: (Ditraversable f, ParamFunctor m, Monad m, Difunctor g)-               => SigFunM m f g -> Term f -> m (Term g)-appTSigFunM f (Term t) = termM (appSigFunM f t)---- | This function applies a monadic signature function to the given--- context. This is a 'top-down variant of 'appSigFunM'.-appSigFunM' :: forall m f g. (Ditraversable g, Monad m)-               => SigFunM m f g -> CxtFunM m f g-appSigFunM' f = run-    where run :: CxtFunM m f g-          run (In t) = liftM In . dimapM run =<< f t-          run (Var x) = return $ Var x-          run (Hole x) = return $ Hole x--{-| A restricted form of |appSigFunM'| which only works for terms. -}-appTSigFunM' :: (Ditraversable g, ParamFunctor m, Monad m, Difunctor g)-                => SigFunM m f g -> Term f -> m (Term g)-appTSigFunM' f (Term t) = termM (appSigFunM' f t)--{-| This function applies a signature function to the given context. -}-appSigFunMD :: forall f g m. (Ditraversable f, Difunctor g, Monad m)-               => SigFunMD m f g -> CxtFunM m f g-appSigFunMD f = run -    where run :: CxtFunM m f g-          run (In t) = liftM In (f (difmap run t))-          run (Hole x) = return (Hole x)-          run (Var p) = return (Var p)--{-| A restricted form of |appSigFunMD| which only works for terms. -}-appTSigFunMD :: (Ditraversable f, ParamFunctor m, Monad m, Difunctor g)-                => SigFunMD m f g -> Term f -> m (Term g)-appTSigFunMD f (Term t) = termM (appSigFunMD f t)--{-| Compose two monadic term homomorphisms. -}-compHomM :: (Ditraversable g, Difunctor h, Monad m)-            => HomM m g h -> HomM m f g -> HomM m f h-compHomM f g = appHomM f <=< g--{-| Compose two monadic term homomorphisms. -}-compHomM' :: (Ditraversable h, Monad m) => HomM m g h -> HomM m f g -> HomM m f h-compHomM' f g = appHomM' f <=< g--{-{-| Compose two monadic term homomorphisms. -}-compHomM_ :: (Difunctor h, Difunctor g, Monad m)-                => Hom g h -> HomM m f g -> HomM m f h-compHomM_ f g = liftM (appHom f) . g--{-| Compose two monadic term homomorphisms. -}-compHomSigFunM :: Monad m => HomM m g h -> SigFunM m f g -> HomM m f h-compHomSigFunM f g = f <=< g-}--{-| Compose two monadic term homomorphisms. -}-compSigFunHomM :: (Ditraversable g, Monad m)-                  => SigFunM m g h -> HomM m f g -> HomM m f h-compSigFunHomM f g = appSigFunM f <=< g--{-| Compose two monadic term homomorphisms. -}-compSigFunHomM' :: (Ditraversable h, Monad m)-                   => SigFunM m g h -> HomM m f g -> HomM m f h-compSigFunHomM' f g = appSigFunM' f <=< g--{-| Compose a monadic algebra with a monadic term homomorphism to get a new-  monadic algebra. -}-compAlgM :: (Ditraversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a-compAlgM alg talg = freeM alg return <=< talg---{-| Compose a monadic algebra with a term homomorphism to get a new monadic-  algebra. -}-compAlgM' :: (Ditraversable g, Monad m) => AlgM m g a -> Hom f g -> AlgM m f a-compAlgM' alg talg = freeM alg return . talg--{-| Compose a monadic algebra with a monadic signature function to get a new-  monadic algebra. -}-compAlgSigFunM :: Monad m => AlgM m g a -> SigFunM m f g -> AlgM m f a-compAlgSigFunM alg talg = alg <=< talg---{-| Compose a monadic algebra with a signature function to get a new monadic-  algebra. -}-compAlgSigFunM' :: AlgM m g a -> SigFun f g -> AlgM m f a-compAlgSigFunM' alg talg = alg . talg--{-| This function composes two monadic signature functions. -}-compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h-compSigFunM f g = f <=< g---------------------- Coalgebras ---------------------{-| This type represents a coalgebra over a difunctor @f@ and carrier @a@. The-  list of @(a,b)@s represent the parameters that may occur in the constructed-  value. The first component represents the seed of the parameter,-  and the second component is the (polymorphic) parameter itself. If @f@ is-  itself a binder, then the parameters bound by @f@ can be passed to the-  covariant argument, thereby making them available to sub terms. -}-type Coalg f a = forall b. a -> [(a,b)] -> Either b (f b (a,[(a,b)]))--{-| Construct an anamorphism from the given coalgebra. -}-ana :: Difunctor f => Coalg f a -> a -> Term f-ana f x = Term $ anaAux f x-    where anaAux :: Difunctor f => Coalg f a -> a -> (forall a. Trm f a)-          anaAux f x = run (x,[])-              where run (a,bs) = case f a bs of-                                   Left p -> Var p-                                   Right t -> In $ difmap run t--{-| This type represents a monadic coalgebra over a difunctor @f@ and carrier-  @a@. -}-type CoalgM m f a = forall b. a -> [(a,b)] -> m (Either b (f b (a,[(a,b)])))--{-| Construct a monadic anamorphism from the given monadic coalgebra. -}-anaM :: forall a m f. (Ditraversable f, Monad m)-     => CoalgM m f a -> a -> forall a. m (Trm f a)-anaM f x = run (x,[])-    where run (a,bs) = do c <- f a bs-                          case c of-                            Left p -> return $ Var p-                            Right t -> liftM In $ dimapM run t-------------------------------------- R-Algebras & Paramorphisms -------------------------------------{-| This type represents an r-algebra over a difunctor @f@ and carrier @a@. -}-type RAlg f a = f a (Trm f a, a) -> a--{-| Construct a paramorphism from the given r-algebra. -}-para :: forall f a. Difunctor f => RAlg f a -> Term f -> a-para f (Term t) = run t-    where run :: Trm f a -> a-          run (In t) = f $ difmap (\x -> (x, run x)) t-          run (Var x) = x--{-| This type represents a monadic r-algebra over a difunctor @f@ and carrier-  @a@. -}-type RAlgM m f a = f a (Trm f a, a) -> m a-{-| Construct a monadic paramorphism from the given monadic r-algebra. -}-paraM :: forall m f a. (Ditraversable f, Monad m) => RAlgM m f a -> Term f -> m a-paraM f (Term t) = run t-    where run :: Trm f a -> m a-          run (In t) = f =<< dimapM (\x -> run x >>= \y -> return (x, y)) t-          run (Var x) = return x-------------------------------------- R-Coalgebras & Apomorphisms -------------------------------------{-| This type represents an r-coalgebra over a difunctor @f@ and carrier @a@. -}-type RCoalg f a = forall b. a -> [(a,b)] -> Either b (f b (Either (Trm f b) (a,[(a,b)])))--{-| Construct an apomorphism from the given r-coalgebra. -}-apo :: Difunctor f => RCoalg f a -> a -> Term f-apo f x = Term (apoAux f x)-    where apoAux :: Difunctor f => RCoalg f a -> a -> (forall a. Trm f a)-          apoAux coa x = run (x,[])-              where -- run :: (a,[(a,b)]) -> Trm f b-                run (a,bs) = case coa a bs of-                               Left x -> Var x-                               Right t -> In $ difmap run' t-                -- run' :: Either (Trm f b) (a,[(a,b)]) -> Trm f b-                run' (Left t) = t-                run' (Right x) = run x----{-| This type represents a monadic r-coalgebra over a functor @f@ and carrier-  @a@. -}-type RCoalgM m f a = forall b. a -> [(a,b)] -> m (Either b (f b (Either (Trm f b) (a,[(a,b)]))))--{-| Construct a monadic apomorphism from the given monadic r-coalgebra. -}-apoM :: forall f m a. (Ditraversable f, Monad m)-        => RCoalgM m f a -> a -> forall a. m (Trm f a)-apoM coa x = run (x,[]) -    where run (a,bs) = do-            res <- coa a bs-            case res of-              Left x -> return $ Var x-              Right t -> liftM In $ dimapM run' t-          run' (Left t) = return t-          run' (Right x) = run x---------------------------------------- CV-Algebras & Histomorphisms ---------------------------------------{-| This type represents a cv-algebra over a difunctor @f@ and carrier @a@. -}-type CVAlg f a f' = f a (Trm f' a) -> a---- | This function applies 'projectA' at the tip of the term.-projectTip  :: DistAnn f a f' => Trm f' a -> a-projectTip (In v) = snd $ projectA v-projectTip (Var p) = p--{-| Construct a histomorphism from the given cv-algebra. -}-histo :: forall f f' a. (Difunctor f, DistAnn f a f')-         => CVAlg f a f' -> Term f -> a-histo alg = projectTip . cata run-    where run :: Alg f (Trm f' a)-          run v = In $ injectA (alg v') v'-              where v' = dimap Var id v--{-| This type represents a monadic cv-algebra over a functor @f@ and carrier-  @a@. -}-type CVAlgM m f a f' = f a (Trm f' a) -> m a--{-| Construct a monadic histomorphism from the given monadic cv-algebra. -}-histoM :: forall f f' m a. (Ditraversable f, Monad m, DistAnn f a f')-          => CVAlgM m f a f' -> Term f -> m a-histoM alg (Term t) = liftM projectTip (run t)-    where run :: Trm f a -> m (Trm f' a)-          run (In t) = do t' <- dimapM run t-                          r <- alg t'-                          return $ In $ injectA r t'-          run (Var p) = return $ Var p----------------------------------------- CV-Coalgebras & Futumorphisms ----------------------------------------{-| This type represents a cv-coalgebra over a difunctor @f@ and carrier @a@.-  The list of @(a,b)@s represent the parameters that may occur in the-  constructed value. The first component represents the seed of the parameter,-  and the second component is the (polymorphic) parameter itself. If @f@ is-  itself a binder, then the parameters bound by @f@ can be passed to the-  covariant argument, thereby making them available to sub terms. -}-type CVCoalg f a = forall b. a -> [(a,b)]-                 -> Either b (f b (Context f b (a,[(a,b)])))--{-| Construct a futumorphism from the given cv-coalgebra. -}-futu :: Difunctor f => CVCoalg f a -> a -> Term f-futu f x = Term (futuAux f x)-    where futuAux :: Difunctor f => CVCoalg f a -> a -> (forall a. Trm f a)-          futuAux coa x = run (x,[])-              where run (a,bs) = case coa a bs of-                                   Left p -> Var p-                                   Right t -> In $ difmap run' t-                    run' (In t) = In $ difmap run' t-                    run' (Hole x) = run x-                    run' (Var p) = Var p--{-| This type represents a monadic cv-coalgebra over a difunctor @f@ and carrier-  @a@. -}-type CVCoalgM m f a = forall b. a -> [(a,b)]-                    -> m (Either b (f b (Context f b (a,[(a,b)]))))--{-| Construct a monadic futumorphism from the given monadic cv-coalgebra. -}-futuM :: forall f a m. (Ditraversable f, Monad m) =>-         CVCoalgM m f a -> a -> forall a. m (Trm f a)-futuM coa x = run (x,[])-    where run (a,bs) = do c <- coa a bs-                          case c of -                            Left p -> return $ Var p-                            Right t -> liftM In $ dimapM run' t-          run' (In t) = liftM In $ dimapM run' t-          run' (Hole x) = run x-          run' (Var p) = return $ Var p--{-| This type represents a generalised cv-coalgebra over a difunctor @f@ and-  carrier @a@. -}-type CVCoalg' f a = forall b. a -> [(a,b)] -> Context f b (a,[(a,b)])--{-| Construct a futumorphism from the given generalised cv-coalgebra. -}-futu' :: Difunctor f => CVCoalg' f a -> a -> Term f-futu' f x = Term (futuAux' f x)-    where futuAux' :: Difunctor f => CVCoalg' f a -> a -> (forall a. Trm f a)-          futuAux' coa x = run (x,[])-              where run (a,bs) = run' $ coa a bs-                    run' (In t) = In $ difmap run' t-                    run' (Hole x) = run x-                    run' (Var p) = Var p--{----------------------------------------------- functions only used for rewrite rules ------------------------------------------------appAlgHom :: forall f g d. Difunctor g => Alg g d -> Hom f g -> Term f -> d-{-# NOINLINE [1] appAlgHom #-}-appAlgHom alg hom (Term t) = run t where-    run :: Trm f d -> d-    run (In t) = run' $ hom t-    run (Var a) = a-    run' :: Context g d (Trm f d) -> d-    run' (In t) = alg $ fmap run' t-    run' (Var a) = a-    run' (Hole x) = run x----- | This function applies a signature function after a term homomorphism.-appSigFunHom :: forall f g h. (Difunctor g)-                => SigFun g h -> Hom f g -> CxtFun f h-{-# NOINLINE [1] appSigFunHom #-}-appSigFunHom f g = run where-    run :: CxtFun f h-    run (In t) = run' $ g t-    run (Var a) = Var a-    run (Hole h) = Hole h-    run' :: Context g a (Cxt h' f a b) -> Cxt h' h a b-    run' (In t) = In $ f $ fmap run' t-    run' (Var a) = Var a-    run' (Hole h) = run h--appAlgHomM :: forall m g f d. Ditraversable g-              => AlgM m g d -> HomM m f g -> Term f -> m d-appAlgHomM alg hom (Term t) = run t where-    run :: Trm f d -> m d-    run (In t) = run' =<< hom t-    run (Var a) = return a-    run' :: Context g d (Trm f d) -> m d-    run' (In t) = alg =<< dimapM run' t-    run' (Var a) = return a-    run' (Hole x) = run x--appHomHomM :: forall m f g h. (Ditraversable g, Difunctor h)-              => HomM m g h -> HomM m f g -> CxtFunM m f h-appHomHomM f g = run where---    run :: CxtFunM m f h-    run (In t) = run' =<< g t-    run (Var a) = return $ Var a-    run (Hole h) = return $ Hole h---    run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b)-    run' (In t) = liftM appCxt $ f =<< dimapM run' t-    run' (Var a) = return $ Var a-    run' (Hole h) = run h--appSigFunHomM :: forall m f g h. Ditraversable g-                 => SigFunM m g h -> HomM m f g -> CxtFunM m f h-appSigFunHomM f g = run where---    run :: CxtFunM m f h-    run (In t) = run' =<< g t-    run (Var a) = return $ Var a-    run (Hole h) = return $ Hole h---    run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b)-    run' (In t) = liftM In $ f =<< dimapM run' t-    run' (Var a) = return $ Var a-    run' (Hole h) = run h------------------------- rewrite rules ------------------------#ifndef NO_RULES-{-# RULES-  "cata/appHom" forall (a :: Alg g d) (h :: Hom f g) x.-    cata a (appHom h x) = cata (compAlg a h) x;--  "cata/appHom'" forall (a :: Alg g d) (h :: Hom f g) x.-    cata a (appHom' h x) = appAlgHom a h x;--  "cata/appSigFun" forall (a :: Alg g d) (h :: SigFun f g) x.-    cata a (appSigFun h x) = cata (compAlgSigFun a h) x;--  "cata/appSigFun'" forall (a :: Alg g d) (h :: SigFun f g) x.-    cata a (appSigFun' h x) = appAlgHom a (hom h) x;--  "cata/appSigFunHom" forall (f :: Alg f3 d) (g :: SigFun f2 f3)-                                      (h :: Hom f1 f2) x.-    cata f (appSigFunHom g h x) = appAlgHom (compAlgSigFun f g) h x;--  "appAlgHom/appHom" forall (a :: Alg h d) (f :: Hom f g) (h :: Hom g h) x.-    appAlgHom a h (appHom f x) = cata (compAlg a (compHom h f)) x;--  "appAlgHom/appHom'" forall (a :: Alg h d) (f :: Hom f g) (h :: Hom g h) x.-    appAlgHom a h (appHom' f x) = appAlgHom a (compHom h f) x;--  "appAlgHom/appSigFun" forall (a :: Alg h d) (f :: SigFun f g) (h :: Hom g h) x.-    appAlgHom a h (appSigFun f x) = cata (compAlg a (compHomSigFun h f)) x;--  "appAlgHom/appSigFun'" forall (a :: Alg h d) (f :: SigFun f g) (h :: Hom g h) x.-    appAlgHom a h (appSigFun' f x) = appAlgHom a (compHomSigFun h f) x;--  "appAlgHom/appSigFunHom" forall (a :: Alg i d) (f :: Hom f g) (g :: SigFun g h)-                                          (h :: Hom h i) x.-    appAlgHom a h (appSigFunHom g f x)-      = appAlgHom a (compHom (compHomSigFun h g) f) x;--  "appHom/appHom" forall (a :: Hom g h) (h :: Hom f g) x.-    appHom a (appHom h x) = appHom (compHom a h) x;--  "appHom'/appHom'" forall (a :: Hom g h) (h :: Hom f g) x.-    appHom' a (appHom' h x) = appHom' (compHom a h) x;--  "appHom'/appHom" forall (a :: Hom g h) (h :: Hom f g) x.-    appHom' a (appHom h x) = appHom (compHom a h) x;--  "appHom/appHom'" forall (a :: Hom g h) (h :: Hom f g) x.-    appHom a (appHom' h x) = appHom' (compHom a h) x;-    -  "appSigFun/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.-    appSigFun f (appSigFun g x) = appSigFun (compSigFun f g) x;--  "appSigFun'/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x.-    appSigFun' f (appSigFun' g x) = appSigFun' (compSigFun f g) x;--  "appSigFun/appSigFun'" forall (f :: SigFun g h) (g :: SigFun f g) x.-    appSigFun f (appSigFun' g x) = appSigFunHom f (hom g) x;--  "appSigFun'/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.-    appSigFun' f (appSigFun g x) = appSigFun (compSigFun f g) x;--  "appHom/appSigFun" forall (f :: Hom g h) (g :: SigFun f g) x.-    appHom f (appSigFun g x) = appHom (compHomSigFun f g) x;--  "appHom/appSigFun'" forall (f :: Hom g h) (g :: SigFun f g) x.-    appHom f (appSigFun' g x) =  appHom' (compHomSigFun f g) x;--  "appHom'/appSigFun'" forall (f :: Hom g h) (g :: SigFun f g) x.-    appHom' f (appSigFun' g x) =  appHom' (compHomSigFun f g) x;--  "appHom'/appSigFun" forall (f :: Hom g h) (g :: SigFun f g) x.-    appHom' f (appSigFun g x) = appHom (compHomSigFun f g) x;-    -  "appSigFun/appHom" forall (f :: SigFun g h) (g :: Hom f g) x.-    appSigFun f (appHom g x) = appSigFunHom f g x;--  "appSigFun'/appHom'" forall (f :: SigFun g h) (g :: Hom f g) x.-    appSigFun' f (appHom' g x) = appHom' (compSigFunHom f g) x;--  "appSigFun/appHom'" forall (f :: SigFun g h) (g :: Hom f g) x.-    appSigFun f (appHom' g x) = appSigFunHom f g x;--  "appSigFun'/appHom" forall (f :: SigFun g h) (g :: Hom f g) x.-    appSigFun' f (appHom g x) = appHom (compSigFunHom f g) x;-    -  "appSigFunHom/appSigFun" forall (f :: SigFun f3 f4) (g :: Hom f2 f3)-                                      (h :: SigFun f1 f2) x.-    appSigFunHom f g (appSigFun h x)-    = appSigFunHom f (compHomSigFun g h) x;--  "appSigFunHom/appSigFun'" forall (f :: SigFun f3 f4) (g :: Hom f2 f3)-                                      (h :: SigFun f1 f2) x.-    appSigFunHom f g (appSigFun' h x)-    = appSigFunHom f (compHomSigFun g h) x;--  "appSigFunHom/appHom" forall (f :: SigFun f3 f4) (g :: Hom f2 f3)-                                      (h :: Hom f1 f2) x.-    appSigFunHom f g (appHom h x)-    = appSigFunHom f (compHom g h) x;--  "appSigFunHom/appHom'" forall (f :: SigFun f3 f4) (g :: Hom f2 f3)-                                      (h :: Hom f1 f2) x.-    appSigFunHom f g (appHom' h x)-    = appSigFunHom f (compHom g h) x;--  "appSigFun/appSigFunHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)-                                      (h :: Hom f1 f2) x.-    appSigFun f (appSigFunHom g h x) = appSigFunHom (compSigFun f g) h x;--  "appSigFun'/appSigFunHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)-                                      (h :: Hom f1 f2) x.-    appSigFun' f (appSigFunHom g h x) = appSigFunHom (compSigFun f g) h x;--  "appHom/appSigFunHom" forall (f :: Hom f3 f4) (g :: SigFun f2 f3)-                                      (h :: Hom f1 f2) x.-    appHom f (appSigFunHom g h x) = appHom' (compHom (compHomSigFun f g) h) x;--  "appHom'/appSigFunHom" forall (f :: Hom f3 f4) (g :: SigFun f2 f3)-                                      (h :: Hom f1 f2) x.-    appHom' f (appSigFunHom g h x) = appHom' (compHom (compHomSigFun f g) h) x;--  "appSigFunHom/appSigFunHom" forall (f1 :: SigFun f4 f5) (f2 :: Hom f3 f4)-                                             (f3 :: SigFun f2 f3) (f4 :: Hom f1 f2) x.-    appSigFunHom f1 f2 (appSigFunHom f3 f4 x)-      = appSigFunHom f1 (compHom (compHomSigFun f2 f3) f4) x;- #-}--{-# RULES -  "cataM/appHomM" forall (a :: AlgM Maybe g d) (h :: HomM Maybe f g) x.-     appHomM h x >>= cataM a =  appAlgHomM a h x;--  "cataM/appHomM'" forall (a :: AlgM Maybe g d) (h :: HomM Maybe f g) x.-     appHomM' h x >>= cataM a = appAlgHomM a h x;--  "cataM/appSigFunM" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.-     appSigFunM h x >>= cataM a = appAlgHomM a (homM h) x;--  "cataM/appSigFunM'" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.-     appSigFunM' h x >>= cataM a = appAlgHomM a (homM h) x;--  "cataM/appHom" forall (a :: AlgM m g d) (h :: Hom f g) x.-     cataM a (appHom h x) = appAlgHomM a (sigFunM h) x;--  "cataM/appHom'" forall (a :: AlgM m g d) (h :: Hom f g) x.-     cataM a (appHom' h x) = appAlgHomM a (sigFunM h) x;--  "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.-     cataM a (appSigFun h x) = appAlgHomM a (sigFunM $ hom h) x;--  "cataM/appSigFun'" forall (a :: AlgM m g d) (h :: SigFun f g) x.-     cataM a (appSigFun' h x) = appAlgHomM a (sigFunM $ hom h) x;--  "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.-     cataM a (appSigFun h x) = appAlgHomM a (sigFunM $ hom h) x;--  "cataM/appSigFunHom" forall (a :: AlgM m h d) (g :: SigFun g h) (f :: Hom f g) x.-     cataM a (appSigFunHom g f x) = appAlgHomM a (sigFunM $ compSigFunHom g f) x;--  "appHomM/appHomM" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM h x >>= appHomM a = appHomM (compHomM a h) x;--  "appHomM/appSigFunM" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM h x >>= appHomM a = appHomM (compHomSigFunM a h) x;--  "appHomM/appHomM'" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM' h x >>= appHomM a = appHomHomM a h x;--  "appHomM/appSigFunM'" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM' h x >>= appHomM a = appHomHomM a (homM h) x;--  "appHomM'/appHomM" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM h x >>= appHomM' a = appHomM' (compHomM' a h) x;--  "appHomM'/appSigFunM" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM h x >>= appHomM' a = appHomM' (compHomSigFunM a h) x;--  "appHomM'/appHomM'" forall (a :: HomM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM' h x >>= appHomM' a = appHomM' (compHomM' a h) x;--  "appHomM'/appSigFunM'" forall (a :: HomM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM' h x >>= appHomM' a = appHomM' (compHomSigFunM a h) x;--  "appHomM/appHom" forall (a :: HomM m g h) (h :: Hom f g) x.-     appHomM a (appHom h x) = appHomHomM a (sigFunM h) x;--  "appHomM/appSigFun" forall (a :: HomM m g h) (h :: SigFun f g) x.-     appHomM a (appSigFun h x) = appHomHomM a (sigFunM $ hom h) x;--  "appHomM'/appHom" forall (a :: HomM m g h) (h :: Hom f g) x.-     appHomM' a (appHom h x) = appHomM' (compHomM' a (sigFunM h)) x;--  "appHomM'/appSigFun" forall (a :: HomM m g h) (h :: SigFun f g) x.-     appHomM' a (appSigFun h x) = appHomM' (compHomSigFunM a (sigFunM h)) x;--  "appHomM/appHom'" forall (a :: HomM m g h) (h :: Hom f g) x.-     appHomM a (appHom' h x) = appHomHomM a (sigFunM h) x;--  "appHomM/appSigFun'" forall (a :: HomM m g h) (h :: SigFun f g) x.-     appHomM a (appSigFun' h x) = appHomHomM a (sigFunM $ hom h) x;--  "appHomM'/appHom'" forall (a :: HomM m g h) (h :: Hom f g) x.-     appHomM' a (appHom' h x) = appHomM' (compHomM' a (sigFunM h)) x;--  "appHomM'/appSigFun'" forall (a :: HomM m g h) (h :: SigFun f g) x.-     appHomM' a (appSigFun' h x) = appHomM' (compHomSigFunM a (sigFunM h)) x;--  "appSigFunM/appHomM" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM h x >>= appSigFunM a = appSigFunHomM a h x;--  "appSigFunHomM/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM h x >>= appSigFunM a = appSigFunM (compSigFunM a h) x;--  "appSigFunM/appHomM'" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM' h x >>= appSigFunM a = appSigFunHomM a h x;--  "appSigFunM/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM' h x >>= appSigFunM a = appSigFunHomM a (homM h) x;--  "appSigFunM'/appHomM" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM h x >>= appSigFunM' a = appHomM' (compSigFunHomM' a h) x;--  "appSigFunM'/appSigFunM" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x;--  "appSigFunM'/appHomM'" forall (a :: SigFunM Maybe g h) (h :: HomM Maybe f g) x.-     appHomM' h x >>= appSigFunM' a = appHomM' (compSigFunHomM' a h) x;--  "appSigFunM'/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.-     appSigFunM' h x >>= appSigFunM' a = appSigFunM' (compSigFunM a h) x;--  "appSigFunM/appHom" forall (a :: SigFunM m g h) (h :: Hom f g) x.-     appSigFunM a (appHom h x) = appSigFunHomM a (sigFunM h) x;--  "appSigFunM/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.-     appSigFunM a (appSigFun h x) = appSigFunHomM a (sigFunM $ hom h) x;--  "appSigFunM'/appHom" forall (a :: SigFunM m g h) (h :: Hom f g) x.-     appSigFunM' a (appHom h x) = appHomM' (compSigFunHomM' a (sigFunM h)) x;--  "appSigFunM'/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.-     appSigFunM' a (appSigFun h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;--  "appSigFunM/appHom'" forall (a :: SigFunM m g h) (h :: Hom f g) x.-     appSigFunM a (appHom' h x) = appSigFunHomM a (sigFunM h) x;--  "appSigFunM/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.-     appSigFunM a (appSigFun' h x) = appSigFunHomM a (sigFunM $ hom h) x;--  "appSigFunM'/appHom'" forall (a :: SigFunM m g h) (h :: Hom f g) x.-     appSigFunM' a (appHom' h x) = appHomM' (compSigFunHomM' a (sigFunM h)) x;--  "appSigFunM'/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.-     appSigFunM' a (appSigFun' h x) = appSigFunM' (compSigFunM a (sigFunM h)) x;---  "appHom/appHomM" forall (a :: Hom g h) (h :: HomM m f g) x.-     appHomM h x >>= (return . appHom a) = appHomM (compHomM_ a h) x;- #-}-#endif--}
− src/Data/Comp/Param/Annotation.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,-  UndecidableInstances, Rank2Types, GADTs, ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Annotation--- Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines annotations on signatures.--------------------------------------------------------------------------------------module Data.Comp.Param.Annotation-    (-     (:&:) (..),-     (:*:) (..),-     DistAnn (..),-     RemA (..),-     liftA,-     liftA',-     stripA,-     propAnn,-     propAnnM,-     ann,-     project'-    ) where--import Data.Comp.Param.Difunctor-import Data.Comp.Param.Term-import Data.Comp.Param.Sum-import Data.Comp.Param.Ops-import Data.Comp.Param.Algebra--import Control.Monad--{-| Transform a function with a domain constructed from a functor to a function- with a domain constructed with the same functor, but with an additional- annotation. -}-liftA :: (RemA s s') => (s' a b -> t) -> s a b -> t-liftA f v = f (remA v)--{-| Transform a function with a domain constructed from a functor to a function-  with a domain constructed with the same functor, but with an additional-  annotation. -}-liftA' :: (DistAnn s' p s, Difunctor s')-          => (s' a b -> Cxt h s' c d) -> s a b -> Cxt h s c d-liftA' f v = let (v',p) = projectA v-             in ann p (f v')--{-| Strip the annotations from a term over a functor with annotations. -}-stripA :: (RemA g f, Difunctor g) => CxtFun g f-stripA = appSigFun remA--{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism- over the same signatures, but extended with annotations. -}-propAnn :: (DistAnn f p f', DistAnn g p g', Difunctor g) -        => Hom f g -> Hom f' g'-propAnn hom f' = ann p (hom f)-    where (f,p) = projectA f'--{-| Lift a monadic term homomorphism over signatures @f@ and @g@ to a monadic-  term homomorphism over the same signatures, but extended with annotations. -}-propAnnM :: (DistAnn f p f', DistAnn g p g', Difunctor g, Monad m) -         => HomM m f g -> HomM m f' g'-propAnnM hom f' = liftM (ann p) (hom f)-    where (f,p) = projectA f'--{-| Annotate each node of a term with a constant value. -}-ann :: (DistAnn f p g, Difunctor f)  => p -> CxtFun f g-ann c = appSigFun (injectA c)--{-| This function is similar to 'project' but applies to signatures-with an annotation which is then ignored. -}-project' :: forall s s' f h a b .  (RemA s s', s :<: f) => -            Cxt h f a b -> Maybe (s' a (Cxt h f a b))-project' v = liftM remA (project v :: Maybe (s a (Cxt h f a b)))
− src/Data/Comp/Param/Derive.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module contains functionality for automatically deriving boilerplate--- code using Template Haskell. Examples include instances of 'Difunctor',--- 'Difoldable', and 'Ditraversable'.--------------------------------------------------------------------------------------module Data.Comp.Param.Derive-    (-     derive,-     -- |Derive boilerplate instances for parametric signatures, i.e.-     -- signatures for parametric compositional data types.--     -- ** EqD-     module Data.Comp.Param.Derive.Equality,-     -- ** OrdD-     module Data.Comp.Param.Derive.Ordering,-     -- ** ShowD-     module Data.Comp.Param.Derive.Show,-     -- ** Difunctor-     module Data.Comp.Param.Derive.Difunctor,-     -- ** Ditraversable-     module Data.Comp.Param.Derive.Ditraversable,-     -- ** Smart Constructors-     module Data.Comp.Param.Derive.SmartConstructors,-     -- ** Smart Constructors w/ Annotations-     module Data.Comp.Param.Derive.SmartAConstructors,-     -- ** Lifting to Sums-     liftSum-    ) where--import Data.Comp.Derive.Utils (derive, liftSumGen)-import Data.Comp.Param.Derive.Equality-import Data.Comp.Param.Derive.Ordering-import Data.Comp.Param.Derive.Show-import Data.Comp.Param.Derive.Difunctor-import Data.Comp.Param.Derive.Ditraversable-import Data.Comp.Param.Derive.SmartConstructors-import Data.Comp.Param.Derive.SmartAConstructors-import Data.Comp.Param.Ops ((:+:), caseD)--import Language.Haskell.TH--{-| Given the name of a type class, where the first parameter is a difunctor,-  lift it to sums of difunctors. Example: @class ShowD f where ...@ is lifted-  as @instance (ShowD f, ShowD g) => ShowD (f :+: g) where ... @. -}-liftSum :: Name -> Q [Dec]-liftSum = liftSumGen 'caseD ''(:+:)
− src/Data/Comp/Param/Derive/Difunctor.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.Functor--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @Difunctor@.--------------------------------------------------------------------------------------module Data.Comp.Param.Derive.Difunctor-    (-     Difunctor,-     makeDifunctor-    ) where--import Data.Comp.Derive.Utils-import Data.Comp.Param.Difunctor-import Language.Haskell.TH--{-| Derive an instance of 'Difunctor' for a type constructor of any parametric-  kind taking at least two arguments. -}-makeDifunctor :: Name -> Q [Dec]-makeDifunctor fname = do-  -- Comments below apply to the example where name = T, args = [a,b,c], and-  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type-  -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args-  -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args-  -- argNames = [a]-  let argNames = map (VarT . tyVarBndrName) (init $ init args)-  -- compType = T a-  let complType = foldl AppT (ConT name) argNames-  -- classType = Difunctor (T a)-  let classType = AppT (ConT ''Difunctor) complType-  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  dimapDecl <- funD 'dimap (map (dimapClause conArg coArg) constrs')-  return [InstanceD [] classType [dimapDecl]]-      where dimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            dimapClause conArg coArg (constr, args) = do-              fn <- newName "_f"-              gn <- newName "_g"-              varNs <- newNames (length args) "x"-              let f = varE fn-              let g = varE gn-              let fp = VarP fn-              let gp = VarP gn-              -- Pattern for the constructor-              let pat = ConP constr $ map VarP varNs-              body <- dimapArgs conArg coArg f g (zip varNs args) (conE constr)-              return $ Clause [fp, gp, pat] (NormalB body) []-            dimapArgs :: Name -> Name -> ExpQ -> ExpQ-                      -> [(Name, Type)] -> ExpQ -> ExpQ-            dimapArgs _ _ _ _ [] acc =-                acc-            dimapArgs conArg coArg f g ((x,tp):tps) acc =-                dimapArgs conArg coArg f g tps-                          (acc `appE` (dimapArg conArg coArg tp f g `appE` varE x))-            -- Given the name of the difunctor variables, a type, and the two-            -- arguments to dimap, return the expression that should be applied-            -- to the parameter of the given type.-            -- Example: dimapArg a b (a -> b) f g yields the expression-            -- [|\x -> g . x . f|]-            dimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ-            dimapArg conArg coArg tp f g-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) = [| id |]-                | otherwise =-                    case tp of-                      VarT a | a == conArg -> f-                             | a == coArg -> g-                      AppT (AppT ArrowT tp1) tp2 -> do-                          xn <- newName "x"-                          let ftp1 = dimapArg conArg coArg tp1 f g-                          let ftp2 = dimapArg conArg coArg tp2 f g-                          lamE [varP xn]-                               (infixE (Just ftp2)-                                       [|(.)|]-                                       (Just $ infixE (Just $ varE xn)-                                                      [|(.)|]-                                                      (Just ftp1)))-                      SigT tp' _ ->-                          dimapArg conArg coArg tp' f g-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| dimap $f $g |]-                          else-                              [| fmap $g |]
− src/Data/Comp/Param/Derive/Ditraversable.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.Ditraversable--- Copyright   :  (c) 2010-2011 Patrick Bahr--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @Ditraversable@.--------------------------------------------------------------------------------------module Data.Comp.Param.Derive.Ditraversable-    (-     Ditraversable,-     makeDitraversable-    ) where--import Data.Comp.Derive.Utils-import Data.Comp.Param.Ditraversable-import Data.Traversable (mapM)-import Language.Haskell.TH-import Data.Maybe-import Control.Monad hiding (mapM)-import Prelude hiding (mapM)--iter 0 _ e = e-iter n f e = iter (n-1) f (f `appE` e)--iter' n f e = run n f e-    where run 0 _ e = e-          run m f e = let f' = iter (m-1) [|fmap|] f-                        in run (m-1) f (f' `appE` e)--{-| Derive an instance of 'Traversable' for a type constructor of any-  first-order kind taking at least one argument. -}-makeDitraversable :: Name -> Q [Dec]-makeDitraversable fname = do-  TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname-  let fArg = VarT . tyVarBndrName $ last args-      aArg = VarT . tyVarBndrName $ last (init args)-      funTy = foldl AppT ArrowT [aArg,fArg]-      argNames = map (VarT . tyVarBndrName) (init $ init args)-      complType = foldl AppT (ConT name) argNames-      classType = foldl1 AppT [ConT ''Ditraversable, complType]-  normConstrs <- mapM normalConExp constrs-  constrs' <- mapM (mkPatAndVars . isFarg fArg funTy) normConstrs-  mapMDecl <- funD 'dimapM (map mapMClause constrs')-  sequenceDecl <- funD 'disequence (map sequenceClause constrs')-  return [InstanceD [] classType [mapMDecl,sequenceDecl]]-      where isFarg fArg funTy (constr, args) =-                (constr, map (\t -> (t `containsType'` fArg, t `containsType'` funTy)) args)-            checksAarg aArg (_,args) = any (`containsType` aArg) args-            filterVar _ _ nonFarg ([],[]) x  = nonFarg x-            filterVar farg _ _ ([depth],[]) x = farg depth x-            filterVar _ aarg _ ([_],[depth]) x = aarg depth x-            filterVar _ _ _ _ _ = error "functor variable occurring twice in argument type"-            filterVars args varNs farg aarg nonFarg = zipWith (filterVar farg aarg nonFarg) args varNs-            mkCPat constr varNs = ConP constr $ map mkPat varNs-            mkPat = VarP-            mkPatAndVars (constr, args) =-                do varNs <- newNames (length args) "x"-                   return (conE constr, mkCPat constr varNs,-                           any (not . null . fst) args || any (not . null . snd) args, map varE varNs,-                           catMaybes $ filterVars args varNs (\x y -> Just (False,x,y)) (\x y -> Just (True, x, y)) (const Nothing))--            -- Note: the monadic versions are not defined-            -- applicatively, as this results in a considerable-            -- performance penalty (by factor 2)!-            mapMClause (con, pat,hasFargs,allVars, fvars) =-                do fn <- newName "f"-                   let f = varE fn-                       fp = if hasFargs then VarP fn else WildP-                       conAp = foldl appE con allVars-                       addDi False _ x = x-                       addDi True d x = [|dimapM $(f)|]-                       conBind (fun,d,x) y = [| $(iter d [|mapM|] (addDi fun d f)) $(varE x)  >>= $(lamE [varP x] y)|]-                   body <- foldr conBind [|return $conAp|] fvars-                   return $ Clause [fp, pat] (NormalB body) []-            sequenceClause (con, pat,hasFargs,allVars, fvars) =-                do let conAp = foldl appE con allVars-                       varE' False _ x = varE x-                       varE' True d x = appE (iter d [|fmap|] [|disequence|]) (varE x)-                       conBind (fun,d, x) y = [| $(iter' d [|sequence|] (varE' fun d x))  >>= $(lamE [varP x] y)|]-                   body <- foldr conBind [|return $conAp|] fvars-                   return $ Clause [pat] (NormalB body) []
− src/Data/Comp/Param/Derive/Equality.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,-  ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.Equality--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @EqD@.-------------------------------------------------------------------------------------module Data.Comp.Param.Derive.Equality-    (-     EqD(..),-     makeEqD-    ) where--import Data.Comp.Derive.Utils-import Data.Comp.Param.FreshM hiding (Name)-import Data.Comp.Param.Equality-import Control.Monad-import Language.Haskell.TH hiding (Cxt, match)--{-| Derive an instance of 'EqD' for a type constructor of any parametric-  kind taking at least two arguments. -}-makeEqD :: Name -> Q [Dec]-makeEqD fname = do-  -- Comments below apply to the example where name = T, args = [a,b,c], and-  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type-  -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args-  -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args-  -- argNames = [a]-  let argNames = map (VarT . tyVarBndrName) (init $ init args)-  -- compType = T a-  let complType = foldl AppT (ConT name) argNames-  -- classType = Difunctor (T a)-  let classType = AppT (ConT ''EqD) complType-  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  let defC = if length constrs < 2 then-                 []-             else-                 [clause [wildP,wildP] (normalB [|return False|]) []]-  eqDDecl <- funD 'eqD (map (eqDClause conArg coArg) constrs' ++ defC)-  let context = map (\arg -> ClassP ''Eq [arg]) argNames-  return [InstanceD context classType [eqDDecl]]-      where eqDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            eqDClause conArg coArg (constr, args) = do-              varXs <- newNames (length args) "x"-              varYs <- newNames (length args) "y"-              -- Patterns for the constructors-              let patx = ConP constr $ map VarP varXs-              let paty = ConP constr $ map VarP varYs-              body <- eqDBody conArg coArg (zip3 varXs varYs args)-              return $ Clause [patx,paty] (NormalB body) []-            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ-            eqDBody conArg coArg x =-                [|liftM and (sequence $(listE $ map (eqDB conArg coArg) x))|]-            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ-            eqDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =-                    [| return $ $(varE x) == $(varE y) |]-                | otherwise =-                    case tp of-                      VarT a-                          | a == coArg -> [| peq $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (VarT a)) _-                          | a == conArg ->-                              [| withName (\v -> peq ($(varE x) v) ($(varE y) v)) |]-                      SigT tp' _ ->-                          eqDB conArg coArg (x, y, tp')-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| eqD $(varE x) $(varE y) |]-                          else-                              [| peq $(varE x) $(varE y) |]
− src/Data/Comp/Param/Derive/Injections.hs 
@@ -1,86 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.Injections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature injections.--------------------------------------------------------------------------------------module Data.Comp.Param.Derive.Injections-    (-     injn,-     injectn,-     deepInjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Param.Difunctor-import Data.Comp.Param.Term-import Data.Comp.Param.Algebra (CxtFun, appSigFun)-import Data.Comp.Param.Ops ((:+:)(..), (:<:)(..))--injn :: Int -> Q [Dec]-injn n = do-  let i = mkName $ "inj" ++ show n-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let bvar = mkName "b"-  let xvar = mkName "x"-  let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ sigD i (genSig fvars gvar avar bvar) : d-    where genSig fvars gvar avar bvar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = arrowT `appT` (tp `appT` varT avar `appT` varT bvar)-                             `appT` (varT gvar `appT` varT avar `appT`-                                     varT bvar)-            forallT (map PlainTV $ gvar : avar : bvar : fvars)-                    (sequence cxt) tp'-          genDecl x n = [| case $(varE x) of-                             Inl x -> $(varE $ mkName "inj") x-                             Inr x -> $(varE $ mkName $ "inj" ++-                                        if n > 2 then show (n - 1) else "") x |]-injectn :: Int -> Q [Dec]-injectn n = do-  let i = mkName ("inject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let avar = mkName "a"-  let bvar = mkName "b"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar avar bvar) : d-    where genSig fvars gvar avar bvar = do-            let hvar = mkName "h"-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar-                                 `appT` varT avar `appT` varT bvar-            let tp'' = arrowT `appT` (tp `appT` varT avar `appT` tp') `appT` tp'-            forallT (map PlainTV $ hvar : gvar : avar : bvar : fvars)-                    (sequence cxt) tp''-          genDecl n = [| In . $(varE $ mkName $ "inj" ++ show n) |]--deepInjectn :: Int -> Q [Dec]-deepInjectn n = do-  let i = mkName ("deepInject" ++ show n)-  let fvars = map (\n -> mkName $ 'f' : show n) [1..n]-  let gvar = mkName "g"-  let d = [funD i [clause [] (normalB $ genDecl n) []]]-  sequence $ sigD i (genSig fvars gvar) : d-    where genSig fvars gvar = do-            let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars-            let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)-                            (map varT fvars)-            let cxt' = classP ''Difunctor [tp]-            let tp' = conT ''CxtFun `appT` tp `appT` varT gvar-            forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
− src/Data/Comp/Param/Derive/Ordering.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,-  ScopedTypeVariables #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.Ordering--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @OrdD@.-------------------------------------------------------------------------------------module Data.Comp.Param.Derive.Ordering-    (-     OrdD(..),-     makeOrdD-    ) where--import Data.Comp.Param.FreshM hiding (Name)-import Data.Comp.Param.Ordering-import Data.Comp.Derive.Utils-import Language.Haskell.TH hiding (Cxt)-import Control.Monad (liftM)--{-| Derive an instance of 'OrdD' for a type constructor of any parametric-  kind taking at least two arguments. -}-makeOrdD :: Name -> Q [Dec]-makeOrdD fname = do-  -- Comments below apply to the example where name = T, args = [a,b,c], and-  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type-  -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args-  -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args-  -- argNames = [a]-  let argNames = map (VarT . tyVarBndrName) (init $ init args)-  -- compType = T a-  let complType = foldl AppT (ConT name) argNames-  -- classType = Difunctor (T a)-  let classType = AppT (ConT ''OrdD) complType-  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  compareDDecl <- funD 'compareD (compareDClauses conArg coArg constrs')-  let context = map (\arg -> ClassP ''Ord [arg]) argNames-  return [InstanceD context classType [compareDDecl]]-      where compareDClauses :: Name -> Name -> [(Name,[Type])] -> [ClauseQ]-            compareDClauses _ _ [] = []-            compareDClauses conArg coArg constrs = -                let constrs' = constrs `zip` [1..]-                    constPairs = [(x,y)| x<-constrs', y <- constrs']-                in map (genClause conArg coArg) constPairs-            genClause conArg coArg ((c,n),(d,m))-                | n == m = genEqClause conArg coArg c-                | n < m = genLtClause c d-                | otherwise = genGtClause c d-            genEqClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            genEqClause conArg coArg (constr, args) = do -              varXs <- newNames (length args) "x"-              varYs <- newNames (length args) "y"-              let patX = ConP constr $ map VarP varXs-              let patY = ConP constr $ map VarP varYs-              body <- eqDBody conArg coArg (zip3 varXs varYs args)-              return $ Clause [patX, patY] (NormalB body) []-            eqDBody :: Name -> Name -> [(Name, Name, Type)] -> ExpQ-            eqDBody conArg coArg x =-                [|liftM compList (sequence $(listE $ map (eqDB conArg coArg) x))|]-            eqDB :: Name -> Name -> (Name, Name, Type) -> ExpQ-            eqDB conArg coArg (x, y, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =-                    [| return $ compare $(varE x) $(varE y) |]-                | otherwise =-                    case tp of-                      VarT a-                          | a == coArg -> [| pcompare $(varE x) $(varE y) |]-                      AppT (AppT ArrowT (VarT a)) _-                          | a == conArg ->-                              [| withName (\v -> pcompare ($(varE x) v) ($(varE y) v)) |]-                      SigT tp' _ ->-                          eqDB conArg coArg (x, y, tp')-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| compareD $(varE x) $(varE y) |]-                          else-                              [| pcompare $(varE x) $(varE y) |]-            genLtClause (c, _) (d, _) =-                clause [recP c [], recP d []] (normalB [| return LT |]) []-            genGtClause (c, _) (d, _) =-                clause [recP c [], recP d []] (normalB [| return GT |]) []
− src/Data/Comp/Param/Derive/Projections.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE TemplateHaskell, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.Projections--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Derive functions for signature projections.--------------------------------------------------------------------------------------module Data.Comp.Param.Derive.Projections-    (-     projn,-     projectn,-     deepProjectn-    ) where--import Language.Haskell.TH hiding (Cxt)-import Control.Monad (liftM)-import Data.Comp.Param.Ditraversable (Ditraversable)-import Data.Comp.Param.Term-import Data.Comp.Param.Algebra (appTSigFunM')-import Data.Comp.Param.Ops ((:+:)(..), (:<:)(..))--projn :: Int -> Q [Dec]-projn n = do-  let p = mkName $ "proj" ++ show n-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let bvar = mkName "b"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar bvar) []]]-  sequence $ (sigD p $ genSig gvars avar bvar) : d-    where genSig gvars avar bvar = do-            let fvar = mkName "f"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = arrowT `appT` (varT fvar `appT` varT avar `appT`-                                     varT bvar)-                             `appT` (conT ''Maybe `appT`-                                     (tp `appT` varT avar `appT` varT bvar))-            forallT (map PlainTV $ fvar : avar : bvar : gvars)-                    (sequence cxt) tp'-          genDecl x [g] a b =-            [| liftM inj (proj $(varE x)-                          :: Maybe ($(varT g `appT` varT a `appT` varT b))) |]-          genDecl x (g:gs) a b =-            [| case (proj $(varE x)-                         :: Maybe ($(varT g `appT` varT a `appT` varT b))) of-                 Just y -> Just $ inj y-                 _ -> $(genDecl x gs a b) |]-          genDecl _ _ _ _ = error "genDecl called with empty list"--projectn :: Int -> Q [Dec]-projectn n = do-  let p = mkName ("project" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let avar = mkName "a"-  let bvar = mkName "b"-  let xvar = mkName "x"-  let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]-  sequence $ (sigD p $ genSig gvars avar bvar) : d-    where genSig gvars avar bvar = do-            let fvar = mkName "f"-            let hvar = mkName "h"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar-                                 `appT` varT avar `appT` varT bvar-            let tp'' = arrowT `appT` tp'-                              `appT` (conT ''Maybe `appT`-                                      (tp `appT` varT avar `appT` tp'))-            forallT (map PlainTV $ hvar : fvar : avar : bvar : gvars)-                    (sequence cxt) tp''-          genDecl x n = [| case $(varE x) of-                             Hole _ -> Nothing-                             Var _ -> Nothing-                             In t -> $(varE $ mkName $ "proj" ++ show n) t |]--deepProjectn :: Int -> Q [Dec]-deepProjectn n = do-  let p = mkName ("deepProject" ++ show n)-  let gvars = map (\n -> mkName $ 'g' : show n) [1..n]-  let d = [funD p [clause [] (normalB $ genDecl n) []]]-  sequence $ (sigD p $ genSig gvars) : d-    where genSig gvars = do-            let fvar = mkName "f"-            let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars-            let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)-                            (map varT gvars)-            let cxt' = classP ''Ditraversable [tp]-            let tp' = arrowT `appT` (conT ''Term `appT` varT fvar)-                             `appT` (conT ''Maybe `appT` (conT ''Term `appT` tp))-            forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'-          genDecl n = [| appTSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
− src/Data/Comp/Param/Derive/Show.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,-  ScopedTypeVariables, UndecidableInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.Show--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive instances of @ShowD@.-------------------------------------------------------------------------------------module Data.Comp.Param.Derive.Show-    (-     ShowD(..),-     makeShowD-    ) where--import Data.Comp.Derive.Utils-import Data.Comp.Param.FreshM hiding (Name)-import qualified Data.Comp.Param.FreshM as FreshM-import Control.Monad-import Language.Haskell.TH hiding (Cxt, match)-import qualified Data.Traversable as T--{-| Signature printing. An instance @ShowD f@ gives rise to an instance-  @Show (Term f)@. -}-class ShowD f where-    showD :: f FreshM.Name (FreshM String) -> FreshM String--newtype Dummy = Dummy String--instance Show Dummy where-  show (Dummy s) = s--{-| Derive an instance of 'ShowD' for a type constructor of any parametric-  kind taking at least two arguments. -}-makeShowD :: Name -> Q [Dec]-makeShowD fname = do-  -- Comments below apply to the example where name = T, args = [a,b,c], and-  -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type-  -- declaration: T a b c = X c | Y a c | Z (b -> c)-  TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname-  -- coArg = c (covariant difunctor argument)-  let coArg :: Name = tyVarBndrName $ last args-  -- conArg = b (contravariant difunctor argument)-  let conArg :: Name = tyVarBndrName $ last $ init args-  -- argNames = [a]-  let argNames = map (VarT . tyVarBndrName) (init $ init args)-  -- compType = T a-  let complType = foldl AppT (ConT name) argNames-  -- classType = Difunctor (T a)-  let classType = AppT (ConT ''ShowD) complType-  -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]-  constrs' :: [(Name,[Type])] <- mapM normalConExp constrs-  showDDecl <- funD 'showD (map (showDClause conArg coArg) constrs')-  let context = map (\arg -> ClassP ''Show [arg]) argNames-  return [InstanceD context classType [showDDecl]]-      where showDClause :: Name -> Name -> (Name,[Type]) -> ClauseQ-            showDClause conArg coArg (constr, args) = do-              varXs <- newNames (length args) "x"-              -- Pattern for the constructor-              let patx = ConP constr $ map VarP varXs-              body <- showDBody (nameBase constr) conArg coArg (zip varXs args)-              return $ Clause [patx] (NormalB body) []-            showDBody :: String -> Name -> Name -> [(Name, Type)] -> ExpQ-            showDBody constr conArg coArg x =-                [|liftM (unwords . (constr :) .-                         map (\x -> if elem ' ' x then "(" ++ x ++ ")" else x))-                        (sequence $(listE $ map (showDB conArg coArg) x))|]-            showDB :: Name -> Name -> (Name, Type) -> ExpQ-            showDB conArg coArg (x, tp)-                | not (containsType tp (VarT conArg)) &&-                  not (containsType tp (VarT coArg)) =-                    [| return $ show $(varE x) |]-                | otherwise =-                    case tp of-                      VarT a-                          | a == coArg -> [| $(varE x) |]-                      AppT (AppT ArrowT (VarT a)) _-                          | a == conArg ->-                              [| withName (\v -> do body <- $(varE x) v;-                                                    return $ "\\" ++ show v ++ " -> " ++ body) |]-                      SigT tp' _ ->-                          showDB conArg coArg (x, tp')-                      _ ->-                          if containsType tp (VarT conArg) then-                              [| showD $(varE x) |]-                          else-                              [| liftM show $ T.mapM (liftM Dummy) $(varE x) |]
− src/Data/Comp/Param/Derive/SmartAConstructors.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.SmartAConstructors--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive smart constructors with annotations for difunctors.--------------------------------------------------------------------------------------module Data.Comp.Param.Derive.SmartAConstructors -    (-     smartAConstructors-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Derive.Utils-import Data.Comp.Param.Ops-import Data.Comp.Param.Term-import Data.Comp.Param.Difunctor--import Control.Monad--{-| Derive smart constructors with annotations for a difunctor. The smart- constructors are similar to the ordinary constructors, but a- 'injectA . dimap Var id' is automatically inserted. -}-smartAConstructors :: Name -> Q [Dec]-smartAConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname-    let cons = map abstractConType constrs-    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons-        where genSmartConstr targs tname (name, args) = do-                let bname = nameBase name-                genSmartConstr' targs tname (mkName $ "iA" ++ bname) name args-              genSmartConstr' targs tname sname name args = do-                varNs <- newNames args "x"-                varPr <- newName "_p"-                let pats = map varP (varPr : varNs)-                    vars = map varE varNs-                    val = appE [|injectA $(varE varPr)|] $-                          appE [|inj . dimap Var id|] $ foldl appE (conE name) vars-                    function = [funD sname [clause pats (normalB [|In $val|]) []]]-                sequence function
− src/Data/Comp/Param/Derive/SmartConstructors.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Derive.SmartConstructors--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ Automatically derive smart constructors for difunctors.--------------------------------------------------------------------------------------module Data.Comp.Param.Derive.SmartConstructors -    (-     smartConstructors-    ) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Derive.Utils-import Data.Comp.Param.Sum-import Data.Comp.Param.Term-import Data.Comp.Param.Difunctor-import Control.Monad--{-| Derive smart constructors for a difunctor. The smart constructors are- similar to the ordinary constructors, but a 'inject . dimap Var id' is- automatically inserted. -}-smartConstructors :: Name -> Q [Dec]-smartConstructors fname = do-    TyConI (DataD _cxt tname targs constrs _deriving) <- abstractNewtypeQ $ reify fname-    let cons = map abstractConType constrs-    liftM concat $ mapM (genSmartConstr (map tyVarBndrName targs) tname) cons-        where genSmartConstr targs tname (name, args) = do-                let bname = nameBase name-                genSmartConstr' targs tname (mkName $ 'i' : bname) name args-              genSmartConstr' targs tname sname name args = do-                varNs <- newNames args "x"-                let pats = map varP varNs-                    vars = map varE varNs-                    val = foldl appE (conE name) vars-                    sig = genSig targs tname sname args-                    function = [funD sname [clause pats (normalB [|inject (dimap Var id $val)|]) []]]-                sequence $ sig ++ function-              genSig targs tname sname 0 = (:[]) $ do-                hvar <- newName "h"-                fvar <- newName "f"-                avar <- newName "a"-                bvar <- newName "b"-                let targs' = init $ init targs-                    vars = hvar:fvar:avar:bvar:targs'-                    h = varT hvar-                    f = varT fvar-                    a = varT avar-                    b = varT bvar-                    ftype = foldl appT (conT tname) (map varT targs')-                    constr = classP ''(:<:) [ftype, f]-                    typ = foldl appT (conT ''Cxt) [h, f, a, b]-                    typeSig = forallT (map PlainTV vars) (sequence [constr]) typ-                sigD sname typeSig-              genSig _ _ _ _ = []
− src/Data/Comp/Param/Desugar.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,-  UndecidableInstances, OverlappingInstances, Rank2Types, TypeOperators #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Desugar--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This modules defines the 'Desugar' type class for desugaring of terms.--------------------------------------------------------------------------------------module Data.Comp.Param.Desugar where--import Data.Comp.Param----- |The desugaring term homomorphism.-class (Difunctor f, Difunctor g) => Desugar f g where-    desugHom :: Hom f g-    desugHom = desugHom' . fmap Hole-    desugHom' :: f a (Cxt h g a b) -> Cxt h g a b-    desugHom' x = appCxt (desugHom x)---- We make the lifting to sums explicit in order to make the Desugar--- class work with the default instance declaration further below.-instance (Desugar f h, Desugar g h) => Desugar (f :+: g) h where-    desugHom = caseD desugHom desugHom---- |Desugar a term.-desugar :: Desugar f g => Term f -> Term g-{-# INLINE desugar #-}-desugar (Term t) = Term (appHom desugHom t)---- |Lift desugaring to annotated terms.-desugarA :: (Difunctor f', Difunctor g', DistAnn f p f', DistAnn g p g',-             Desugar f g) => Term f' -> Term g'-desugarA (Term t) = Term (appHom (propAnn desugHom) t)---- |Default desugaring instance.-instance (Difunctor f, Difunctor g, f :<: g) => Desugar f g where-    desugHom = simpCxt . inj
− src/Data/Comp/Param/Difunctor.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Difunctor--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines difunctors (Meijer, Hutton, FPCA '95), i.e. binary type--- constructors that are contravariant in the first argument and covariant in--- the second argument.--------------------------------------------------------------------------------------module Data.Comp.Param.Difunctor-    (-      difmap,-     Difunctor(..)-    ) where---- | This class represents difunctors, i.e. binary type constructors that are--- contravariant in the first argument and covariant in the second argument.-class Difunctor f where-    dimap :: (a -> b) -> (c -> d) -> f b c -> f a d--{-| The canonical example of a difunctor. -}-instance Difunctor (->) where-    dimap f g h = g . h . f--difmap :: Difunctor f => (a -> b) -> f c a -> f c b-difmap = dimap id--instance Difunctor f => Functor (f a) where-    fmap = difmap
− src/Data/Comp/Param/Ditraversable.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Ditraversable--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines traversable difunctors.--------------------------------------------------------------------------------------module Data.Comp.Param.Ditraversable-    (-     Ditraversable(..)-    ) where--import Data.Comp.Param.Difunctor--{-| Difunctors representing data structures that can be traversed from left to-  right. -}-class Difunctor f => Ditraversable f where-    dimapM :: Monad m => (b -> m c) -> f a b -> m (f a c)-    dimapM f = disequence . fmap f-    disequence :: Monad m => f a (m b) -> m (f a b)-    disequence = dimapM id
− src/Data/Comp/Param/Equality.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,-  UndecidableInstances, IncoherentInstances, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Equality--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines equality for signatures, which lifts to equality for--- terms.-------------------------------------------------------------------------------------module Data.Comp.Param.Equality-    (-     PEq(..),-     EqD(..)-    ) where--import Data.Comp.Param.Term-import Data.Comp.Param.Sum-import Data.Comp.Param.Ops-import Data.Comp.Param.Difunctor-import Data.Comp.Param.FreshM-import Control.Monad (liftM)---- |Equality on parametric values. The equality test is performed inside the--- 'FreshM' monad for generating fresh identifiers.-class PEq a where-    peq :: a -> a -> FreshM Bool--instance PEq a => PEq [a] where-    peq l1 l2-        | length l1 /= length l2 = return False-        | otherwise = liftM or $ mapM (uncurry peq) $ zip l1 l2--instance Eq a => PEq a where-    peq x y = return $ x == y--{-| Signature equality. An instance @EqD f@ gives rise to an instance-  @Eq (Term f)@. The equality test is performed inside the 'FreshM' monad for-  generating fresh identifiers. -}-class EqD f where-    eqD :: PEq a => f Name a -> f Name a -> FreshM Bool--{-| 'EqD' is propagated through sums. -}-instance (EqD f, EqD g) => EqD (f :+: g) where-    eqD (Inl x) (Inl y) = eqD x y-    eqD (Inr x) (Inr y) = eqD x y-    eqD _ _ = return False--{-| From an 'EqD' difunctor an 'Eq' instance of the corresponding term type can-  be derived. -}-instance EqD f => EqD (Cxt h f) where-    eqD (In e1) (In e2) = eqD e1 e2-    eqD (Hole h1) (Hole h2) = peq h1 h2-    eqD (Var p1) (Var p2) = peq p1 p2-    eqD _ _ = return False--instance (EqD f, PEq a) => PEq (Cxt h f Name a) where-    peq = eqD--{-| Equality on terms. -}-instance (Difunctor f, EqD f) => Eq (Term f) where-    (==) (Term x) (Term y) = evalFreshM $ eqD x y
− src/Data/Comp/Param/FreshM.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.FreshM--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines a monad for generating fresh, abstract names, useful--- e.g. for defining equality on terms.-------------------------------------------------------------------------------------module Data.Comp.Param.FreshM-    (-     FreshM,-     Name,-     withName,-     evalFreshM-    ) where--import Control.Monad.Reader---- |Monad for generating fresh (abstract) names.-newtype FreshM a = FreshM{unFreshM :: Reader Int a}-    deriving Monad---- |Abstract notion of a name (the constructor is hidden).-newtype Name = Name Int-    deriving Eq--instance Show Name where-    show (Name x) = names !! x-        where baseNames = ['a'..'z']-              names = map (:[]) baseNames ++ names' 1-              names' n = map (: show n) baseNames ++ names' (n + 1)--instance Ord Name where-    compare (Name x) (Name y) = compare x y---- |Run the given computation with the next available name.-withName :: (Name -> FreshM a) -> FreshM a-withName m = do name <- FreshM (asks Name)-                FreshM $ local ((+) 1) $ unFreshM $ m name---- |Evaluate a computation that uses fresh names.-evalFreshM :: FreshM a -> a-evalFreshM (FreshM m) = runReader m 0
− src/Data/Comp/Param/Ops.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies,-  FlexibleInstances, UndecidableInstances, IncoherentInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Ops--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module provides operators on difunctors.--------------------------------------------------------------------------------------module Data.Comp.Param.Ops where--import Data.Comp.Param.Difunctor-import Data.Comp.Param.Ditraversable-import Control.Monad (liftM)----- Sums-infixr 6 :+:---- |Formal sum of signatures (difunctors).-data (f :+: g) a b = Inl (f a b)-                   | Inr (g a b)--{-| Utility function to case on a difunctor sum, without exposing the internal-  representation of sums. -}-caseD :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c-caseD f g x = case x of-                Inl x -> f x-                Inr x -> g x--instance (Difunctor f, Difunctor g) => Difunctor (f :+: g) where-    dimap f g (Inl e) = Inl (dimap f g e)-    dimap f g (Inr e) = Inr (dimap f g e)--instance (Ditraversable f, Ditraversable g) => Ditraversable (f :+: g) where-    dimapM f (Inl e) = Inl `liftM` dimapM f e-    dimapM f (Inr e) = Inr `liftM` dimapM f e-    disequence (Inl e) = Inl `liftM` disequence e-    disequence (Inr e) = Inr `liftM` disequence e---- | Signature containment relation for automatic injections. The left-hand must--- be an atomic signature, where as the right-hand side must have a list-like--- structure. Examples include @f :<: f :+: g@ and @g :<: f :+: (g :+: h)@,--- non-examples include @f :+: g :<: f :+: (g :+: h)@ and--- @f :<: (f :+: g) :+: h@.-class sub :<: sup where-  inj :: sub a b -> sup a b-  proj :: sup a b -> Maybe (sub a b)--instance (:<:) f f where-    inj = id-    proj = Just--instance (:<:) f (f :+: g) where-    inj = Inl-    proj (Inl x) = Just x-    proj (Inr _) = Nothing--instance (f :<: g) => (:<:) f (h :+: g) where-    inj = Inr . inj-    proj (Inr x) = proj x-    proj (Inl _) = Nothing----- Products-infixr 8 :*:---- |Formal product of signatures (difunctors).-data (f :*: g) a b = f a b :*: g a b--ffst :: (f :*: g) a b -> f a b-ffst (x :*: _) = x--fsnd :: (f :*: g) a b -> g a b-fsnd (_ :*: x) = x----- Constant Products-infixr 7 :&:--{-| This data type adds a constant product to a signature. -}-data (f :&: p) a b = f a b :&: p--instance Difunctor f => Difunctor (f :&: p) where-    dimap f g (v :&: c) = dimap f g v :&: c--instance Ditraversable f => Ditraversable (f :&: p) where-    dimapM f (v :&: c) = liftM (:&: c) (dimapM f v)-    disequence (v :&: c) = liftM (:&: c) (disequence v)--{-| This class defines how to distribute an annotation over a sum of-  signatures. -}-class DistAnn s p s' | s' -> s, s' -> p where-    {-| Inject an annotation over a signature. -}-    injectA :: p -> s a b -> s' a b-    {-| Project an annotation from a signature. -}-    projectA :: s' a b -> (s a b, p)--class RemA s s' | s -> s'  where-    {-| Remove annotations from a signature. -}-    remA :: s a b -> s' a b--instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where-    remA (Inl (v :&: _)) = Inl v-    remA (Inr v) = Inr $ remA v--instance RemA (f :&: p) f where-    remA (v :&: _) = v--instance DistAnn f p (f :&: p) where-    injectA c v = v :&: c--    projectA (v :&: p) = (v,p)--instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where-    injectA c (Inl v) = Inl (v :&: c)-    injectA c (Inr v) = Inr $ injectA c v--    projectA (Inl (v :&: p)) = (Inl v,p)-    projectA (Inr v) = let (v',p) = projectA v-                       in  (Inr v',p)
− src/Data/Comp/Param/Ordering.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,-  UndecidableInstances, IncoherentInstances, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Ordering--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines ordering of signatures, which lifts to ordering of--- terms and contexts.-------------------------------------------------------------------------------------module Data.Comp.Param.Ordering-    (-     POrd(..),-     OrdD(..),-     compList-    ) where--import Data.Comp.Param.Term-import Data.Comp.Param.Sum-import Data.Comp.Param.Ops-import Data.Comp.Param.Difunctor-import Data.Comp.Param.FreshM-import Data.Comp.Param.Equality-import Data.Maybe (fromMaybe)-import Data.List (find)-import Control.Monad (liftM)---- |Ordering of parametric values.-class PEq a => POrd a where-    pcompare :: a -> a -> FreshM Ordering--instance POrd a => POrd [a] where-    pcompare l1 l2-        | length l1 < length l2 = return LT-        | length l1 > length l2 = return GT-        | otherwise = liftM compList $ mapM (uncurry pcompare) $ zip l1 l2--compList :: [Ordering] -> Ordering-compList = fromMaybe EQ . find (/= EQ)--instance Ord a => POrd a where-    pcompare x y = return $ compare x y--{-| Signature ordering. An instance @OrdD f@ gives rise to an instance-  @Ord (Term f)@. -}-class EqD f => OrdD f where-    compareD :: POrd a => f Name a -> f Name a -> FreshM Ordering--{-| 'OrdD' is propagated through sums. -}-instance (OrdD f, OrdD g) => OrdD (f :+: g) where-    compareD (Inl x) (Inl y) = compareD x y-    compareD (Inl _) (Inr _) = return LT-    compareD (Inr x) (Inr y) = compareD x y-    compareD (Inr _) (Inl _) = return GT--{-| From an 'OrdD' difunctor an 'Ord' instance of the corresponding term type-  can be derived. -}-instance OrdD f => OrdD (Cxt h f) where-    compareD (In e1) (In e2) = compareD e1 e2-    compareD (Hole h1) (Hole h2) = pcompare h1 h2-    compareD (Var p1) (Var p2) = pcompare p1 p2-    compareD (In _) _ = return LT-    compareD (Hole _) (In _) = return GT-    compareD (Hole _) (Var _) = return LT-    compareD (Var _) _ = return GT--instance (OrdD f, POrd a) => POrd (Cxt h f Name a) where-    pcompare = compareD--{-| Ordering of terms. -}-instance (Difunctor f, OrdD f) => Ord (Term f) where-    compare (Term x) (Term y) = evalFreshM $ compareD x y
− src/Data/Comp/Param/Show.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances,-  IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Show--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines showing of signatures, which lifts to showing of terms.-------------------------------------------------------------------------------------module Data.Comp.Param.Show-    (-     ShowD(..)-    ) where--import Data.Comp.Param.Term-import Data.Comp.Param.Ops-import Data.Comp.Param.Derive-import Data.Comp.Param.FreshM---- Lift ShowD to sums-$(derive [liftSum] [''ShowD])--{-| From an 'ShowD' difunctor an 'ShowD' instance of the corresponding term type-  can be derived. -}-instance (Difunctor f, ShowD f) => ShowD (Cxt h f) where-    showD (In t) = showD $ fmap showD t-    showD (Hole h) = h-    showD (Var p) = return $ show p--{-| Printing of terms. -}-instance (Difunctor f, ShowD f) => Show (Term f) where-    show = evalFreshM . showD . toCxt . unTerm--instance (ShowD f, Show p) => ShowD (f :&: p) where-    showD (x :&: p) = do sx <- showD x-                         return $ sx ++ " :&: " ++ show p
− src/Data/Comp/Param/Sum.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,-  FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,-  ScopedTypeVariables, TemplateHaskell, Rank2Types #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Sum--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module provides the infrastructure to extend signatures.--------------------------------------------------------------------------------------module Data.Comp.Param.Sum-    (-     (:<:),-     (:+:),-     caseD,--     -- * Projections for Signatures and Terms-     proj,-     proj2,-     proj3,-     proj4,-     proj5,-     proj6,-     proj7,-     proj8,-     proj9,-     proj10,-     project,-     project2,-     project3,-     project4,-     project5,-     project6,-     project7,-     project8,-     project9,-     project10,-     deepProject,-     deepProject2,-     deepProject3,-     deepProject4,-     deepProject5,-     deepProject6,-     deepProject7,-     deepProject8,-     deepProject9,-     deepProject10,--     -- * Injections for Signatures and Terms-     inj,-     inj2,-     inj3,-     inj4,-     inj5,-     inj6,-     inj7,-     inj8,-     inj9,-     inj10,-     inject,-     inject',-     inject2,-     inject3,-     inject4,-     inject5,-     inject6,-     inject7,-     inject8,-     inject9,-     inject10,-     deepInject,-     deepInject2,-     deepInject3,-     deepInject4,-     deepInject5,-     deepInject6,-     deepInject7,-     deepInject8,-     deepInject9,-     deepInject10,--     injectCxt,-     liftCxt-    ) where--import Prelude hiding (sequence)-import Control.Monad hiding (sequence)-import Data.Comp.Param.Term-import Data.Comp.Param.Algebra-import Data.Comp.Param.Ops-import Data.Comp.Param.Derive.Projections-import Data.Comp.Param.Derive.Injections-import Data.Comp.Param.Difunctor-import Data.Comp.Param.Ditraversable--$(liftM concat $ mapM projn [2..10])---- |Project the outermost layer of a term to a sub signature. If the signature--- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.-project :: (g :<: f) => Cxt h f a b -> Maybe (g a (Cxt h f a b))-project (In t) = proj t-project (Hole _) = Nothing-project (Var _) = Nothing--$(liftM concat $ mapM projectn [2..10])---- | Tries to coerce a term/context to a term/context over a sub-signature. If--- the signature @g@ is compound of /n/ atomic signatures, use--- @deepProject@/n/ instead.-deepProject :: (Ditraversable g, g :<: f) => Term f -> Maybe (Term g)-{-# INLINE deepProject #-}-deepProject = appTSigFunM' proj--$(liftM concat $ mapM deepProjectn [2..10])-{-# INLINE deepProject2 #-}-{-# INLINE deepProject3 #-}-{-# INLINE deepProject4 #-}-{-# INLINE deepProject5 #-}-{-# INLINE deepProject6 #-}-{-# INLINE deepProject7 #-}-{-# INLINE deepProject8 #-}-{-# INLINE deepProject9 #-}-{-# INLINE deepProject10 #-}--$(liftM concat $ mapM injn [2..10])---- |Inject a term where the outermost layer is a sub signature. If the signature--- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.-inject :: (g :<: f) => g a (Cxt h f a b) -> Cxt h f a b-inject = In . inj---- |Inject a term where the outermost layer is a sub signature. If the signature--- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.-inject' :: (Difunctor g, g :<: f) => g (Cxt h f a b) (Cxt h f a b) -> Cxt h f a b-inject' = inject . dimap Var id--$(liftM concat $ mapM injectn [2..10])---- |Inject a term over a sub signature to a term over larger signature. If the--- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/--- instead.-deepInject :: (Difunctor g, g :<: f) => Term g -> Term f-{-# INLINE deepInject #-}-deepInject (Term t) = Term (appSigFun inj t)--$(liftM concat $ mapM deepInjectn [2..10])-{-# INLINE deepInject2 #-}-{-# INLINE deepInject3 #-}-{-# INLINE deepInject4 #-}-{-# INLINE deepInject5 #-}-{-# INLINE deepInject6 #-}-{-# INLINE deepInject7 #-}-{-# INLINE deepInject8 #-}-{-# INLINE deepInject9 #-}-{-# INLINE deepInject10 #-}--{-| This function injects a whole context into another context. -}-injectCxt :: (Difunctor g, g :<: f) => Cxt h g a (Cxt h f a b) -> Cxt h f a b-injectCxt (In t) = inject $ difmap injectCxt t-injectCxt (Hole x) = x-injectCxt (Var p) = Var p--{-| This function lifts the given functor to a context. -}-liftCxt :: (Difunctor f, g :<: f) => g a b -> Cxt Hole f a b-liftCxt g = simpCxt $ inj g--instance (Show (f a b), Show (g a b)) => Show ((f :+: g) a b) where-    show (Inl v) = show v-    show (Inr v) = show v--instance (Ord (f a b), Ord (g a b)) => Ord ((f :+: g) a b) where-    compare (Inl _) (Inr _) = LT-    compare (Inr _) (Inl _) = GT-    compare (Inl x) (Inl y) = compare x y-    compare (Inr x) (Inr y) = compare x y--instance (Eq (f a b), Eq (g a b)) => Eq ((f :+: g) a b) where-    (Inl x) == (Inl y) = x == y-    (Inr x) == (Inr y) = x == y                   -    _ == _ = False
− src/Data/Comp/Param/Term.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, Rank2Types,-  MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}------------------------------------------------------------------------------------ |--- Module      :  Data.Comp.Param.Term--- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved--- License     :  BSD3--- Maintainer  :  Tom Hvitved <hvitved@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This module defines the central notion of /parametrised terms/ and their--- generalisation to parametrised contexts.--------------------------------------------------------------------------------------module Data.Comp.Param.Term-    (-     Cxt(..),-     Hole,-     NoHole,-     Term(..),-     Trm,-     Context,-     simpCxt,-     toCxt,-     cxtMap,-     ParamFunctor(..)-    ) where--import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)-import Data.Comp.Param.Difunctor-import Unsafe.Coerce (unsafeCoerce)--import Data.Maybe (fromJust)--{-| This data type represents contexts over a signature. Contexts are terms-  containing zero or more holes, and zero or more parameters. The first-  parameter is a phantom type indicating whether the context has holes. The-  second paramater is the signature of the context, in the form of a-  "Data.Comp.Param.Difunctor". The third parameter is the type of parameters,-  and the fourth parameter is the type of holes. -}-data Cxt :: * -> (* -> * -> *) -> * -> * -> * where-            In :: f a (Cxt h f a b) -> Cxt h f a b-            Hole :: b -> Cxt Hole f a b-            Var :: a -> Cxt h f a b--{-| Phantom type used to define 'Context'. -}-data Hole--{-| Phantom type used to define 'Term'. -}-data NoHole--{-| A context may contain holes. -}-type Context = Cxt Hole--{-| \"Preterms\" -}-type Trm f a = Cxt NoHole f a ()--{-| A term is a context with no holes, where all occurrences of the-  contravariant parameter is fully parametric. -}-newtype Term f = Term{unTerm :: forall a. Trm f a}--{-| Convert a difunctorial value into a context. -}-simpCxt :: Difunctor f => f a b -> Cxt Hole f a b-{-# INLINE simpCxt #-}-simpCxt = In . difmap Hole--toCxt :: Difunctor f => Trm f a -> Cxt h f a b-{-# INLINE toCxt #-}-toCxt = unsafeCoerce---- | This combinator maps a function over a context by applying the--- function to each hole.-cxtMap :: Difunctor f => (b -> c) -> Context f a b -> Context f a c-cxtMap f (Hole x) = Hole (f x)-cxtMap _ (Var x)  = Var x-cxtMap f (In t)   = In (dimap id (cxtMap f) t)---- Param Functor--{-| Monads for which embedded @Trm@ values, which are parametric at top level,-  can be made into monadic @Term@ values, i.e. \"pushing the parametricity-  inwards\". -}-class ParamFunctor m where-    termM :: (forall a. m (Trm f a)) -> m (Term f)--coerceTermM :: ParamFunctor m => (forall a. m (Trm f a)) -> m (Term f)-{-# INLINE coerceTermM #-}-coerceTermM t = unsafeCoerce t--{-# RULES-    "termM/coerce" termM = coerceTermM- #-}--instance ParamFunctor Maybe where-    termM Nothing = Nothing-    termM x       = Just (Term $ fromJust x)--instance ParamFunctor (Either a) where-    termM (Left x) = Left x-    termM x        = Right (Term $ fromRight x)-                             where fromRight :: Either a b -> b-                                   fromRight (Right x) = x-                                   fromRight _ = error "fromRight: Left"--instance ParamFunctor [] where-    termM [] = []-    termM l  = Term (head l) : termM (tail l)
− src/Data/Comp/Param/Thunk.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE TypeOperators, FlexibleContexts, Rank2Types, GADTs #-}------------------------------------------------------------------------------------- |--- Module      :  Data.Comp.Param.Thunk--- Copyright   :  (c) 2011 Patrick Bahr--- License     :  BSD3--- Maintainer  :  Patrick Bahr <paba@diku.dk>--- Stability   :  experimental--- Portability :  non-portable (GHC Extensions)------ This modules defines terms & contexts with thunks, with deferred--- monadic computations.--------------------------------------------------------------------------------------module Data.Comp.Param.Thunk-    (TermT-    ,TrmT-    ,CxtT-    ,Thunk-    ,thunk-    ,whnf-    ,whnf'-    ,whnfPr-    ,nf-    ,nfT-    ,nfPr-    ,nfTPr-    ,evalStrict-    ,AlgT-    ,strict-    ,strict')- where--import Data.Comp.Param.Term-import Data.Comp.Param.Sum-import Data.Comp.Param.Ops-import Data.Comp.Param.Algebra-import Data.Comp.Param.Ditraversable-import Data.Comp.Param.Difunctor--import Control.Monad---- | This type represents terms with thunks.-type TermT m f = Term (Thunk m :+: f)---- | This type represents terms with thunks.-type TrmT m f a = Trm  (Thunk m :+: f) a---- | This type represents contexts with thunks.-type CxtT h  m f a = Cxt h (Thunk m :+: f) a--newtype Thunk m a b = Thunk (m b)---- | This function turns a monadic computation into a thunk.-thunk :: (Thunk m :<: f) => m (Cxt h f a b) -> Cxt h f a b-thunk = inject . Thunk---- | This function evaluates all thunks until a non-thunk node is--- found.-whnf :: Monad m => TrmT m f a -> m (Either a (f a (TrmT m f a)))-whnf (In (Inl (Thunk m))) = m >>= whnf-whnf (In (Inr t)) = return $ Right t-whnf (Var x) = return $ Left x--whnf' :: Monad m => TrmT m f a -> m (TrmT m f a)-whnf' =  liftM (either Var inject) . whnf---- | This function first evaluates the argument term into whnf via--- 'whnf' and then projects the top-level signature to the desired--- subsignature. Failure to do the projection is signalled as a--- failure in the monad.-whnfPr :: (Monad m, g :<: f) => TrmT m f a -> m (g a (TrmT m f a))-whnfPr t = do res <- whnf t-              case res of-                Left _  -> fail "cannot project variable"-                Right t ->-                    case proj t of-                      Just res' -> return res'-                      Nothing -> fail "projection failed"----- | This function evaluates all thunks.-nfT :: (ParamFunctor m, Monad m, Ditraversable f) => TermT m f -> m (Term f)-nfT t = termM $ nf $ unTerm  t---- | This function evaluates all thunks.-nf :: (Monad m, Ditraversable f) => TrmT m f a -> m (Trm f a)-nf = either (return . Var) (liftM In . dimapM nf) <=< whnf---- | This function evaluates all thunks while simultaneously--- projecting the term to a smaller signature. Failure to do the--- projection is signalled as a failure in the monad as in 'whnfPr'.-nfTPr :: (ParamFunctor m, Monad m, Ditraversable g, g :<: f) => TermT m f -> m (Term g)-nfTPr t = termM $ nfPr $ unTerm t---- | This function evaluates all thunks while simultaneously--- projecting the term to a smaller signature. Failure to do the--- projection is signalled as a failure in the monad as in 'whnfPr'.-nfPr :: (Monad m, Ditraversable g, g :<: f) => TrmT m f a -> m (Trm g a)-nfPr = liftM In . dimapM nfPr <=< whnfPr---evalStrict :: (Ditraversable g, Monad m, g :<: f) => -              (g (TrmT m f a) (f a (TrmT m f a)) -> TrmT m f a)-           -> g (TrmT m f a) (TrmT m f a) -> TrmT m f a-evalStrict cont t = thunk $ do -                      t' <- dimapM (liftM (either (const Nothing) Just) . whnf) t-                      case disequence t' of-                        Nothing -> return $ inject' t-                        Just s -> return $ cont s-                      ---- | This type represents algebras which have terms with thunks as--- carrier.-type AlgT m f g = Alg f (TermT m g)---- | This combinator makes the evaluation of the given functor--- application strict by evaluating all thunks of immediate subterms.-strict :: (f :<: g, Ditraversable f, Monad m) => f a (TrmT m g a) -> TrmT m g a-strict x = thunk $ liftM inject $ dimapM whnf' x---- | This combinator makes the evaluation of the given functor--- application strict by evaluating all thunks of immediate subterms.-strict' :: (f :<: g, Ditraversable f, Monad m) => f (TrmT m g a) (TrmT m g a) -> TrmT m g a-strict'  = strict . dimap Var id
+ src/Data/Comp/Projection.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.Projection+-- Copyright   :  (c) 2014 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@di.ku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- This module provides a generic projection function 'pr' for+-- arbitrary nested binary products.+--+--------------------------------------------------------------------------------+++module Data.Comp.Projection (pr, (:<)) where++import Data.Comp.SubsumeCommon++import Data.Kind++type family Elem (f :: Type)+                 (g :: Type) :: Emb where+    Elem f f = Found Here+    Elem (f1, f2) g =  Sum' (Elem f1 g) (Elem f2 g)+    Elem f (g1, g2) = Choose (Elem f g1) (Elem f g2)+    Elem f g = NotFound++class Proj (e :: Emb) (p :: Type)+                      (q :: Type) where+    pr'  :: Proxy e -> q -> p++instance Proj (Found Here) f f where+    pr' _ = id++instance Proj (Found p) f g => Proj (Found (Le p)) f (g, g') where+    pr' _ = pr' (P :: Proxy (Found p)) . fst+++instance Proj (Found p) f g => Proj (Found (Ri p)) f (g', g) where+    pr' _ = pr' (P :: Proxy (Found p)) . snd+++instance (Proj (Found p1) f1 g, Proj (Found p2) f2 g)+    => Proj (Found (Sum p1 p2)) (f1, f2) g where+    pr' _ x = (pr' (P :: Proxy (Found p1)) x, pr' (P :: Proxy (Found p2)) x)+++infixl 5 :<++-- | The constraint @e :< p@ expresses that @e@ is a component of the+-- type @p@. That is, @p@ is formed by binary products using the type+-- @e@. The occurrence of @e@ must be unique. For example we have @Int+-- :< (Bool,(Int,Bool))@ but not @Bool :< (Bool,(Int,Bool))@.++type f :< g = (Proj (ComprEmb (Elem f g)) f g)+++-- | This function projects the component of type @e@ out or the+-- compound value of type @p@.++pr :: forall p q . (p :< q) => q -> p+pr = pr' (P :: Proxy (ComprEmb (Elem p q)))
+ src/Data/Comp/Render.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Data.Comp.Render where++import Data.Comp+import Data.Comp.Derive+import Data.Comp.Show ()+import Data.Foldable (toList)+import Data.Tree (Tree (..))+import Data.Tree.View++-- | The 'stringTree' algebra of a functor. The default instance creates a tree+-- with the same structure as the term.+class (Functor f, Foldable f, ShowConstr f) => Render f where+    stringTreeAlg :: Alg f (Tree String)+    stringTreeAlg f = Node (showConstr f) $ toList f++-- | Convert a term to a 'Tree'+stringTree :: Render f => Term f -> Tree String+stringTree = cata stringTreeAlg++-- | Show a term using ASCII art+showTerm :: Render f => Term f -> String+showTerm = showTree . stringTree++-- | Print a term using ASCII art+drawTerm :: Render f => Term f -> IO ()+drawTerm = putStrLn . showTerm++-- | Write a term to an HTML file with foldable nodes+writeHtmlTerm :: Render f => FilePath -> Term f -> IO ()+writeHtmlTerm file+    = writeHtmlTree Nothing file+    . fmap (\n -> NodeInfo InitiallyExpanded n "") . stringTree++$(derive [liftSum] [''Render])
src/Data/Comp/Show.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE TypeOperators, GADTs, TemplateHaskell, TypeSynonymInstances #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Show@@ -17,12 +20,12 @@     ( ShowF(..)     ) where -import Data.Comp.Term-import Data.Comp.Annotation import Data.Comp.Algebra+import Data.Comp.Annotation import Data.Comp.Derive (liftSum)-import Data.Comp.Derive.Utils (derive) import Data.Comp.Derive.Show+import Data.Comp.Derive.Utils (derive)+import Data.Comp.Term  instance (Functor f, ShowF f) => ShowF (Cxt h f) where     showF (Hole s) = s@@ -36,3 +39,8 @@  $(derive [liftSum] [''ShowF]) $(derive [makeShowF] [''Maybe, ''[], ''(,)])++instance (ShowConstr f, Show p) => ShowConstr (f :&: p) where+    showConstr (v :&: p) = showConstr v ++ " :&: " ++ show p++$(derive [liftSum] [''ShowConstr])
+ src/Data/Comp/SubsumeCommon.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds            #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Data.Comp.SubsumeCommon+-- Copyright   :  (c) 2014 Patrick Bahr+-- License     :  BSD3+-- Maintainer  :  Patrick Bahr <paba@diku.dk>+-- Stability   :  experimental+-- Portability :  non-portable (GHC Extensions)+--+-- Shared parts of the implementation of signature subsumption for+-- both the base and the multi library.+--+--------------------------------------------------------------------------------++module Data.Comp.SubsumeCommon+    ( ComprEmb+    , Pos (..)+    , Emb (..)+    , Choose+    , Sum'+    , Proxy (..)+    ) where++-- | This type is used in its promoted form only. It represents+-- pointers from the left-hand side of a subsumption to the right-hand+-- side.+data Pos = Here | Le Pos | Ri Pos | Sum Pos Pos++-- | This type is used in its promoted form only. It represents+-- possible results for checking for subsumptions. 'Found' indicates a+-- subsumption was found; 'NotFound' indicates no such subsumption was+-- found. 'Ambiguous' indicates that there are duplicates on the left-+-- or the right-hand side.+data Emb = Found Pos | NotFound | Ambiguous++data Proxy a = P+++type family Choose (e1 :: Emb) (r :: Emb) :: Emb where+    Choose (Found x) (Found y) = Ambiguous+    Choose Ambiguous y = Ambiguous+    Choose x Ambiguous = Ambiguous+    Choose (Found x) y = Found (Le x)+    Choose x (Found y) = Found (Ri y)+    Choose x y = NotFound+++type family Sum' (e1 :: Emb) (r :: Emb) :: Emb where+    Sum' (Found x) (Found y) = Found (Sum x y)+    Sum' Ambiguous y = Ambiguous+    Sum' x Ambiguous = Ambiguous+    Sum' NotFound y = NotFound+    Sum' x NotFound = NotFound+++-- | This type family takes a position type and compresses it. That+-- means it replaces each nested occurrence of+--+-- @+--   Sum (prefix (Le Here)) (prefix (Ri Here))@+-- @+---+-- with+--+-- @+--   prefix Here@+-- @+--+-- where @prefix@ is some composition of @Le@ and @Ri@. The rational+-- behind this type family is that it provides a more compact proof+-- term of a subsumption, and thus yields more efficient+-- implementations of 'inj' and 'prj'.++type family ComprPos (p :: Pos) :: Pos where+    ComprPos Here = Here+    ComprPos (Le p) = Le (ComprPos p)+    ComprPos (Ri p) = Ri (ComprPos p)+    ComprPos (Sum l r) = CombineRec (ComprPos l) (ComprPos r)+++-- | Helper type family for 'ComprPos'. Note that we could have+-- defined this as a type synonym. But if we do that, performance+-- becomes abysmal. I presume that the reason for this huge impact on+-- performance lies in the fact that right-hand side of the defining+-- equation duplicates the two arguments @l@ and @r@.+type family CombineRec l r where+    CombineRec l r = CombineMaybe (Sum l r) (Combine l r)++-- | Helper type family for 'ComprPos'.+type family CombineMaybe (p :: Pos) (p' :: Maybe Pos) where+    CombineMaybe p (Just p') = p'+    CombineMaybe p p'        = p+++-- | Helper type family for 'ComprPos'.+type family Combine (l :: Pos) (r :: Pos) :: Maybe Pos where+    Combine (Le l) (Le r) = Le' (Combine l r)+    Combine (Ri l) (Ri r) = Ri' (Combine l r)+    Combine (Le Here) (Ri Here) = Just Here+    Combine l r = Nothing++-- | 'Ri' lifted to 'Maybe'.+type family Ri' (p :: Maybe Pos) :: Maybe Pos where+    Ri' Nothing = Nothing+    Ri' (Just p) = Just (Ri p)++-- | 'Le' lifted to 'Maybe'.+type family Le' (p :: Maybe Pos) :: Maybe Pos where+    Le' Nothing = Nothing+    Le' (Just p) = Just (Le p)+++-- | If the argument is not 'Found', this type family is the+-- identity. Otherwise, the argument is of the form @Found p@, and+-- this type family does two things: (1) it checks whether @p@ the+-- contains duplicates; and (2) it compresses @p@ using 'ComprPos'. If+-- (1) finds no duplicates, @Found (ComprPos p)@ is returned;+-- otherwise @Ambiguous@ is returned.+--+-- For (1) it is assumed that @p@ does not contain 'Sum' nested+-- underneath a 'Le' or 'Ri' (i.e. only at the root or underneath a+-- 'Sum'). We will refer to such positions below as /atomic position/.+-- Positions not containing 'Sum' are called /simple positions/.+type family ComprEmb (e :: Emb) :: Emb where+    ComprEmb (Found p) = Check (Dupl p) (ComprPos p)+    ComprEmb e = e++-- | Helper type family for 'ComprEmb'.+type family Check (b :: Bool) (p :: Pos) where+    Check False p = Found p+    Check True  p = Ambiguous++-- | This type family turns a list of /atomic position/ into a list of+-- /simple positions/ by recursively splitting each position of the+-- form @Sum p1 p2@ into @p1@ and @p2@.+type family ToList (s :: [Pos]) :: [Pos] where+    ToList (Sum p1 p2 ': s) = ToList (p1 ': p2 ': s)+    ToList (p ': s) = p ': ToList s+    ToList '[] = '[]++-- | This type checks whether the argument (atomic) position has+-- duplicates.+type Dupl s = Dupl' (ToList '[s])++-- | This type family checks whether the list of positions given as an+-- argument contains any duplicates.+type family Dupl' (s :: [Pos]) :: Bool where+    Dupl' (p ': r) = OrDupl' (Find p r) r+    Dupl' '[] = False++-- | This type family checks whether its first argument is contained+-- its second argument.+type family Find (p :: Pos) (s :: [Pos]) :: Bool where+    Find p (p ': r)  = True+    Find p (p' ': r) = Find p r+    Find p '[] = False++-- | This type family returns @True@ if the first argument is true;+-- otherwise it checks the second argument for duplicates.+type family OrDupl' (a :: Bool) (b :: [Pos]) :: Bool where+    OrDupl'  True  c  = True+    OrDupl'  False c  = Dupl' c
src/Data/Comp/Sum.hs view
@@ -1,6 +1,12 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,-  FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,-  ScopedTypeVariables, TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE TypeSynonymInstances  #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Sum@@ -17,77 +23,28 @@ module Data.Comp.Sum     (      (:<:),+     (:=:),      (:+:),      caseF,       -- * Projections for Signatures and Terms      proj,-     proj2,-     proj3,-     proj4,-     proj5,-     proj6,-     proj7,-     proj8,-     proj9,-     proj10,      project,-     project2,-     project3,-     project4,-     project5,-     project6,-     project7,-     project8,-     project9,-     project10,      deepProject,-     deepProject2,-     deepProject3,-     deepProject4,-     deepProject5,-     deepProject6,-     deepProject7,-     deepProject8,-     deepProject9,-     deepProject10,+     project_,+     deepProject_,       -- * Injections for Signatures and Terms      inj,-     inj2,-     inj3,-     inj4,-     inj5,-     inj6,-     inj7,-     inj8,-     inj9,-     inj10,      inject,-     inject2,-     inject3,-     inject4,-     inject5,-     inject6,-     inject7,-     inject8,-     inject9,-     inject10,      deepInject,-     deepInject2,-     deepInject3,-     deepInject4,-     deepInject5,-     deepInject6,-     deepInject7,-     deepInject8,-     deepInject9,-     deepInject10,+     inject_,+     deepInject_, +     split,+      -- * Injections and Projections for Constants      injectConst,-     injectConst2,-     injectConst3,      projectConst,      injectCxt,      liftCxt,@@ -95,31 +52,30 @@      substHoles'     ) where -import Data.Comp.Term import Data.Comp.Algebra import Data.Comp.Ops-import Data.Comp.Derive.Projections-import Data.Comp.Derive.Injections+import Data.Comp.Term -import Control.Monad hiding (mapM,sequence)-import Prelude hiding (mapM,sequence)+import Control.Monad hiding (mapM, sequence)+import Prelude hiding (mapM, sequence) -import Data.Maybe-import Data.Traversable import Data.Map (Map) import qualified Data.Map as Map+import Data.Maybe  -$(liftM concat $ mapM projn [2..10])- -- |Project the outermost layer of a term to a sub signature. If the signature -- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead. project :: (g :<: f) => Cxt h f a -> Maybe (g (Cxt h f a))-project (Hole _) = Nothing-project (Term t) = proj t+project = project_ proj -$(liftM concat $ mapM projectn [2..10])+-- |Project the outermost layer of a term to a sub signature. If the signature+-- @g@ is compound of /n/ atomic signatures, use @project@/n/ instead.+project_ :: SigFunM Maybe f g -> Cxt h f a -> Maybe (g (Cxt h f a))+project_ _ (Hole _) = Nothing+project_ f (Term t) = f t + -- | Tries to coerce a term/context to a term/context over a sub-signature. If -- the signature @g@ is compound of /n/ atomic signatures, use -- @deepProject@/n/ instead.@@ -127,55 +83,47 @@ {-# INLINE deepProject #-} deepProject = appSigFunM' proj -$(liftM concat $ mapM deepProjectn [2..10])-{-# INLINE deepProject2 #-}-{-# INLINE deepProject3 #-}-{-# INLINE deepProject4 #-}-{-# INLINE deepProject5 #-}-{-# INLINE deepProject6 #-}-{-# INLINE deepProject7 #-}-{-# INLINE deepProject8 #-}-{-# INLINE deepProject9 #-}-{-# INLINE deepProject10 #-}+-- | Tries to coerce a term/context to a term/context over a sub-signature. If+-- the signature @g@ is compound of /n/ atomic signatures, use+-- @deepProject@/n/ instead.+deepProject_ :: (Traversable g) => (SigFunM Maybe f g) -> CxtFunM Maybe f g+{-# INLINE deepProject_ #-}+deepProject_ = appSigFunM' -$(liftM concat $ mapM injn [2..10])  -- |Inject a term where the outermost layer is a sub signature. If the signature -- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead. inject :: (g :<: f) => g (Cxt h f a) -> Cxt h f a-inject = Term . inj+inject = inject_ inj -$(liftM concat $ mapM injectn [2..10])+-- |Inject a term where the outermost layer is a sub signature. If the signature+-- @g@ is compound of /n/ atomic signatures, use @inject@/n/ instead.+inject_ :: SigFun g f -> g (Cxt h f a) -> Cxt h f a+inject_ f = Term . f + -- |Inject a term over a sub signature to a term over larger signature. If the -- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/ -- instead. deepInject :: (Functor g, g :<: f) => CxtFun g f {-# INLINE deepInject #-}-deepInject = appSigFun inj+deepInject = deepInject_ inj -$(liftM concat $ mapM deepInjectn [2..10])-{-# INLINE deepInject2 #-}-{-# INLINE deepInject3 #-}-{-# INLINE deepInject4 #-}-{-# INLINE deepInject5 #-}-{-# INLINE deepInject6 #-}-{-# INLINE deepInject7 #-}-{-# INLINE deepInject8 #-}-{-# INLINE deepInject9 #-}-{-# INLINE deepInject10 #-}+-- |Inject a term over a sub signature to a term over larger signature. If the+-- signature @g@ is compound of /n/ atomic signatures, use @deepInject@/n/+-- instead.+deepInject_ :: (Functor g) => SigFun g f -> CxtFun g f+{-# INLINE deepInject_ #-}+deepInject_ = appSigFun ++split :: (f :=: f1 :+: f2) => (f1 (Term f) -> a) -> (f2 (Term f) -> a) -> Term f -> a+split f1 f2 (Term t) = spl f1 f2 t+ injectConst :: (Functor g, g :<: f) => Const g -> Cxt h f a injectConst = inject . fmap (const undefined) -injectConst2 :: (Functor f1, Functor f2, Functor g, f1 :<: g, f2 :<: g)-             => Const (f1 :+: f2) -> Cxt h g a-injectConst2 = inject2 . fmap (const undefined) -injectConst3 :: (Functor f1, Functor f2, Functor f3, Functor g, f1 :<: g, f2 :<: g, f3 :<: g)-             => Const (f1 :+: f2 :+: f3) -> Cxt h g a-injectConst3 = inject3 . fmap (const undefined)- projectConst :: (Functor g, g :<: f) => Cxt h f a -> Maybe (Const g) projectConst = fmap (fmap (const ())) . project @@ -197,11 +145,7 @@ substHoles' :: (Functor f, Functor g, f :<: g, Ord v) => Cxt h' f v -> Map v (Cxt h g a) -> Cxt h g a substHoles' c m = substHoles c (fromJust . (`Map.lookup`  m)) -instance (Functor f) => Monad (Context f) where-    return = Hole-    (>>=) = substHoles - instance (Show (f a), Show (g a)) => Show ((f :+: g) a) where     show (Inl v) = show v     show (Inr v) = show v@@ -216,5 +160,5 @@  instance (Eq (f a), Eq (g a)) => Eq ((f :+: g) a) where     (Inl x) == (Inl y) = x == y-    (Inr x) == (Inr y) = x == y                   +    (Inr x) == (Inr y) = x == y     _ == _ = False
src/Data/Comp/Term.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, Rank2Types #-}+{-# LANGUAGE EmptyDataDecls       #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE KindSignatures       #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE TypeSynonymInstances #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Term@@ -30,11 +35,12 @@ import Control.Applicative hiding (Const) import Control.Monad hiding (mapM, sequence) -import Data.Traversable+import Data.Kind import Data.Foldable+import Data.Traversable import Unsafe.Coerce -import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)+import Prelude hiding (foldl, foldl1, foldr, foldr1, mapM, sequence)   {-|  -}@@ -53,7 +59,7 @@ second parameter is the signature of the context. The third parameter is the type of the holes. -} -data Cxt :: * -> (* -> *) -> * -> * where+data Cxt :: Type -> (Type -> Type) -> Type -> Type where             Term :: f (Cxt h f a) -> Cxt h f a             Hole :: a -> Cxt Hole f a @@ -94,6 +100,15 @@         where run (Hole v) = Hole (f v)               run (Term t) = Term (fmap run t) +instance Functor f => Applicative (Context f) where+    pure = Hole+    (<*>) = ap++instance (Functor f) => Monad (Context f) where+    m >>= f = run m+        where run (Hole v) = f v+              run (Term t) = Term (fmap run t)+ instance (Foldable f) => Foldable (Cxt h f) where     foldr op c a = run a c         where run (Hole a) e = a `op` e@@ -114,11 +129,11 @@     traverse f = run         where run (Hole a) = Hole <$> f a               run (Term t) = Term <$> traverse run t-                          +     sequenceA (Hole a) = Hole <$> a     sequenceA (Term t) = Term <$> traverse sequenceA t -    mapM f = run +    mapM f = run         where run (Hole a) = liftM Hole $ f a               run (Term t) = liftM Term $ mapM run t
src/Data/Comp/TermRewriting.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE Rank2Types, GADTs #-}+{-# LANGUAGE GADTs      #-}+{-# LANGUAGE Rank2Types #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.TermRewriting@@ -17,16 +18,16 @@  import Prelude hiding (any) -import Data.Comp.Term-import Data.Comp.Sum import Data.Comp.Algebra import Data.Comp.Equality import Data.Comp.Matching+import Data.Comp.Sum+import Data.Comp.Term+import Data.Foldable import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.Set as Set import Data.Maybe-import Data.Foldable+import qualified Data.Set as Set  import Control.Monad @@ -84,7 +85,7 @@  appRule :: (Ord v, EqF f, Eq a, Functor f, Foldable f)           => Rule f f v -> Step (Cxt h f a)-appRule rule t = do +appRule rule t = do   (res, subst) <- matchRule rule t   return $ substHoles' res subst @@ -134,10 +135,10 @@ parallelStep _ Hole{} = Nothing parallelStep trs c@(Term t) =     case matchRules trs c of-      Nothing +      Nothing           | anyBelow -> Just $ Term $ fmap fst below           | otherwise -> Nothing-        where below = fmap (bStep $ parallelStep trs) t +        where below = fmap (bStep $ parallelStep trs) t               anyBelow = any snd below       Just (rhs,subst) -> Just $ substHoles' rhs substBelow           where rhsVars = Set.fromList $ toList rhs@@ -145,7 +146,7 @@                 apply v t                     | Set.member v rhsVars = Just $ fst $ bStep (parallelStep trs) t                     | otherwise = Nothing-                +  {-| This function applies the given reduction step repeatedly until a normal form is reached. -}
src/Data/Comp/Thunk.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE TypeOperators, FlexibleContexts, Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}  -------------------------------------------------------------------------------- -- |@@ -36,20 +41,20 @@     ,strict     ,strictAt) where -import Data.Comp.Term-import Data.Comp.Equality import Data.Comp.Algebra-import Data.Comp.Ops+import Data.Comp.Equality+import Data.Comp.Mapping+import Data.Comp.Ops ((:+:) (..), fromInr) import Data.Comp.Sum-import Data.Comp.Number+import Data.Comp.Term import Data.Foldable hiding (and) -import qualified Data.Set as Set+import qualified Data.IntSet as IntSet +import Control.Monad hiding (mapM, sequence) import Data.Traversable-import Control.Monad hiding (sequence,mapM) -import Prelude hiding (foldr, foldl,foldr1, foldl1,sequence,mapM)+import Prelude hiding (foldl, foldl1, foldr, foldr1, mapM, sequence)   -- | This type represents terms with thunks.@@ -60,8 +65,8 @@   -- | This function turns a monadic computation into a thunk.-thunk :: (m :<: f) => m (Cxt h f a) -> Cxt h f a-thunk = inject+thunk :: m (CxtT m h f a) -> CxtT m h f a+thunk = inject_ Inl  -- | This function evaluates all thunks until a non-thunk node is -- found.@@ -70,13 +75,13 @@ whnf (Term (Inr t)) = return t  whnf' :: Monad m => TermT m f -> m (TermT m f)-whnf' = liftM inject . whnf+whnf' = liftM (inject_ Inr) . whnf  -- | This function first evaluates the argument term into whnf via -- 'whnf' and then projects the top-level signature to the desired -- subsignature. Failure to do the projection is signalled as a -- failure in the monad.-whnfPr :: (Monad m, g :<: f) => TermT m f -> m (g (TermT m f))+whnfPr :: (MonadFail m, g :<: f) => TermT m f -> m (g (TermT m f)) whnfPr t = do res <- whnf t               case proj res of                 Just res' -> return res'@@ -98,7 +103,7 @@ -- (using 'whnf') according to the given function. eval2 :: Monad m => (f (TermT m f) -> f (TermT m f) -> TermT m f)                  -> TermT m f -> TermT m f -> TermT m f-eval2 cont x y = (\ x' -> cont x' `eval` y) `eval` x +eval2 cont x y = (\ x' -> cont x' `eval` y) `eval` x  -- | This function evaluates all thunks. nf :: (Monad m, Traversable f) => TermT m f -> m (Term f)@@ -107,16 +112,16 @@ -- | This function evaluates all thunks while simultaneously -- projecting the term to a smaller signature. Failure to do the -- projection is signalled as a failure in the monad as in 'whnfPr'.-nfPr :: (Monad m, Traversable g, g :<: f) => TermT m f -> m (Term g)+nfPr :: (MonadFail m, Traversable g, g :<: f) => TermT m f -> m (Term g) nfPr = liftM Term . mapM nfPr <=< whnfPr  -- | This function inspects a term (using 'nf') according to the -- given function.-deepEval :: (Traversable f, Monad m) => +deepEval :: (Traversable f, Monad m) =>             (Term f -> TermT m f) -> TermT m f -> TermT m f-deepEval cont v = case deepProject v of +deepEval cont v = case deepProject_ fromInr v of                     Just v' -> cont v'-                    _ -> thunk $ liftM cont $ nf v +                    _ -> thunk $ liftM cont $ nf v  infixl 1 #>> @@ -150,22 +155,22 @@ -- | This combinator makes the evaluation of the given functor -- application strict by evaluating all thunks of immediate subterms. strict :: (f :<: g, Traversable f, Monad m) => f (TermT m g) -> TermT m g-strict x = thunk $ liftM inject $ mapM whnf' x+strict x = thunk $ liftM (inject_ (Inr . inj)) $ mapM whnf' x  -- | This type represents position representations for a functor -- @f@. It is a function that extracts a number of components (of -- polymorphic type @a@) from a functorial value and puts it into a -- list.-type Pos f = forall a . Ord a => f a -> [a]+type Pos f = forall a . f a -> [a]  -- | This combinator is a variant of 'strict' that only makes a subset -- of the arguments of a functor application strict. The first -- argument of this combinator specifies which positions are supposed -- to be strict. strictAt :: (f :<: g, Traversable f, Monad m) => Pos f ->  f (TermT m g) -> TermT m g-strictAt p s = thunk $ liftM inject $ mapM run s'+strictAt p s = thunk $ liftM (inject_ (Inr . inj)) $ mapM run s'     where s'  = number s-          isStrict e = Set.member e $ Set.fromList $ p s'+          isStrict (Numbered i _) = IntSet.member i $ IntSet.fromList $ map (\(Numbered i _) -> i) $ p s'           run e | isStrict e = whnf' $ unNumbered e                 | otherwise  = return $ unNumbered e
src/Data/Comp/Unification.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-} ------------------------------------------------------------------------------- -- | -- Module      :  Data.Comp.Unification@@ -15,15 +16,14 @@  module Data.Comp.Unification where +import Data.Comp.Decompose import Data.Comp.Term import Data.Comp.Variables-import Data.Comp.Decompose -import Control.Monad.Error+import Control.Monad+import Control.Monad.Except import Control.Monad.State -import Data.Traversable- import qualified Data.Map as Map  {-| This type represents equations between terms over a specific@@ -42,10 +42,6 @@                    | HeadSymbolMismatch (Term f) (Term f)                    | UnifError String -instance Error (UnifError f v) where-    strMsg = UnifError-- -- | This is used in order to signal a failed occurs check during -- unification. failedOccursCheck :: (MonadError (UnifError f v) m) => v -> Term f -> m a@@ -87,12 +83,12 @@ withNextEq :: Monad m            => (Equation f -> UnifyM f v m ()) -> UnifyM f v m () withNextEq m = do eqs <- gets usEqs-                  case eqs of +                  case eqs of                     [] -> return ()                     x : xs -> modify (\s -> s {usEqs = xs})                            >> m x -putEqs :: Monad m +putEqs :: Monad m        => Equations f -> UnifyM f v m () putEqs eqs = modify addEqs     where addEqs s = s {usEqs = eqs ++ usEqs s}@@ -108,7 +104,7 @@          => UnifyM f v m () runUnify = withNextEq (\ e -> unifyStep e >> runUnify) -unifyStep :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f), Traversable f) +unifyStep :: (MonadError (UnifError f v) m, Decompose f v, Ord v, Eq (Const f), Traversable f)           => Equation f -> UnifyM f v m () unifyStep (s,t) = case decompose s of                     Var v1 -> case decompose t of
src/Data/Comp/Variables.hs view
@@ -1,5 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,-  OverlappingInstances, TypeOperators, TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeOperators         #-}  -------------------------------------------------------------------------------- -- |@@ -29,20 +32,24 @@      substVars,      appSubst,      compSubst,-     getBoundVars+     getBoundVars,+    (&),+    (|->),+    empty     ) where -import Data.Comp.Term-import Data.Comp.Number import Data.Comp.Algebra import Data.Comp.Derive+import Data.Comp.Mapping+import Data.Comp.Term+import Data.Comp.Ops import Data.Foldable hiding (elem, notElem)+import Data.Map (Map)+import qualified Data.Map as Map import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set-import Data.Map (Map)-import qualified Data.Map as Map-import Prelude hiding (or, foldl)+import Prelude hiding (foldl, or)  -- | This type represents substitutions of contexts, i.e. finite -- mappings from variables to contexts.@@ -60,61 +67,69 @@     -- default implementation returns @Nothing@.     isVar :: f a -> Maybe v     isVar _ = Nothing-    +     -- | Indicates the set of variables bound by the @f@ constructor     -- for each argument of the constructor. For example for a     -- non-recursive let binding:+    --      -- @     -- data Let e = Let Var e e     -- instance HasVars Let Var where-    --   bindsVars (Let v x y) = Map.fromList [(y, (Set.singleton v))]+    --   bindsVars (Let v x y) = y |-> Set.singleton v     -- @+    --      -- If, instead, the let binding is recursive, the methods has to     -- be implemented like this:+    --      -- @-    --   bindsVars (Let v x y) = Map.fromList [(x, (Set.singleton v)),-    --                                         (y, (Set.singleton v))]+    --   bindsVars (Let v x y) = x |-> Set.singleton v &+    --                           y |-> Set.singleton v     -- @+    --      -- This indicates that the scope of the bound variable also     -- extends to the right-hand side of the variable binding.     --     -- The default implementation returns the empty map.-    bindsVars :: Ord a => f a -> Map a (Set v)-    bindsVars _ = Map.empty+    bindsVars :: Mapping m a => f a -> m (Set v)+    bindsVars _ = empty   $(derive [liftSum] [''HasVars]) +instance HasVars f v => HasVars (f :&: a) v where+  isVar (f :&: _)     = isVar f+  bindsVars (f :&: _) = bindsVars f+ -- | Same as 'isVar' but it returns Nothing@ instead of @Just v@ if -- @v@ is contained in the given set of variables.-    + isVar' :: (HasVars f v, Ord v) => Set v -> f a -> Maybe v isVar' b t = do v <- isVar t                 if v `Set.member` b                    then Nothing                    else return v-   + -- | This combinator pairs every argument of a given constructor with -- the set of (newly) bound variables according to the corresponding -- 'HasVars' type class instance. getBoundVars :: (HasVars f v, Traversable f) => f a -> f (Set v, a) getBoundVars t = let n = number t                      m = bindsVars n-                     trans x = (Map.findWithDefault Set.empty x m, unNumbered x)+                     trans (Numbered i x) = (lookupNumMap Set.empty i m, x)                  in fmap trans n-                    + -- | This combinator combines 'getBoundVars' with the generic 'fmap' function. fmapBoundVars :: (HasVars f v, Traversable f) => (Set v -> a -> b) -> f a -> f b fmapBoundVars f t = let n = number t                         m = bindsVars n-                        trans x = f (Map.findWithDefault Set.empty x m) (unNumbered x)-                    in fmap trans n                    -                    --- | This combinator combines 'getBoundVars' with the generic 'foldl' function.   +                        trans (Numbered i x) = f (lookupNumMap Set.empty i m) x+                    in fmap trans n++-- | This combinator combines 'getBoundVars' with the generic 'foldl' function. foldlBoundVars :: (HasVars f v, Traversable f) => (b -> Set v -> a -> b) -> b -> f a -> b foldlBoundVars f e t = let n = number t                            m = bindsVars n-                           trans x y = f x (Map.findWithDefault Set.empty y m) (unNumbered y) +                           trans x (Numbered i y) = f x (lookupNumMap Set.empty i m) y                        in foldl trans e n  -- | Convert variables to holes, except those that are bound.@@ -124,7 +139,7 @@           alg t vars = case isVar t of             Just v | not (v `Set.member` vars) -> Hole v             _  -> Term $ fmapBoundVars run t-              where +              where                 run newVars f = f $ newVars `Set.union` vars  -- |Algebra for checking whether a variable is contained in a term, except those@@ -175,19 +190,19 @@ appSubst subst = substVars f     where f v = Map.lookup v subst -instance (Ord v, HasVars f v, Traversable f)+instance  {-# OVERLAPPABLE #-} (Ord v, HasVars f v, Traversable f)     => SubstVars v (Cxt h f a) (Cxt h f a) where         -- have to use explicit GADT pattern matching!!         -- subst f = free (substAlg f) Hole   substVars subst = doSubst Set.empty     where doSubst _ (Hole a) = Hole a-          doSubst b (Term t) = case isVar' b t >>= subst of +          doSubst b (Term t) = case isVar' b t >>= subst of             Just new -> new             Nothing  -> Term $ fmapBoundVars run t-              where run vars s = doSubst (b `Set.union` vars) s+              where run vars = doSubst (b `Set.union` vars) -instance (SubstVars v t a, Functor f) => SubstVars v t (f a) where-    substVars f = fmap (substVars f) +instance  {-# OVERLAPPABLE #-} (SubstVars v t a, Functor f) => SubstVars v t (f a) where+    substVars f = fmap (substVars f)  {-| This function composes two substitutions @s1@ and @s2@. That is, applying the resulting substitution is equivalent to first applying
testsuite/tests/Data/Comp/Equality_Test.hs view
@@ -2,13 +2,12 @@   import Data.Comp-import Data.Comp.Equality-import Data.Comp.Arbitrary-import Data.Comp.Show+import Data.Comp.Equality ()+import Data.Comp.Arbitrary ()+import Data.Comp.Show ()  import Test.Framework import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck import Test.Utils  @@ -34,4 +33,4 @@                    Nothing -> False                    Just list -> all (uncurry (==)) $ map (\(x,y)->(f x,y)) list     where cxt' = fmap f cxt -          with = (cxt :: Context SigP Int, f :: Int -> Int)+          _with = (cxt :: Context SigP Int, f :: Int -> Int)
testsuite/tests/Data/Comp/Examples/Comp.hs view
@@ -11,10 +11,6 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit-import Test.Utils hiding (iPair)---   --------------------------------------------------------------------------------
testsuite/tests/Data/Comp/Examples/Multi.hs view
@@ -12,7 +12,6 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit-import Test.Utils hiding (iPair)  -------------------------------------------------------------------------------- -- Test Suits
− testsuite/tests/Data/Comp/Examples/MultiParam.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Data.Comp.Examples.MultiParam where--import Examples.MultiParam.FOL as FOL--import Data.Comp.MultiParam-import Data.Comp.MultiParam.FreshM (Name)--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit-import Test.Utils----------------------------------------------------------------------------------------- Test Suits-----------------------------------------------------------------------------------tests = testGroup "Parametric Compositional Data Types" [-         testCase "FOL" folTest-        ]-------------------------------------------------------------------------------------- Properties-----------------------------------------------------------------------------------folTest = show (foodFact7 :: INF Name TFormula) @=? "(Person(x1) and Food(x2)) -> (Food(Skol2(x1)) or Person(Skol6(x2)))\n" ++-          "(Person(x1) and Food(x2)) -> (Food(Skol2(x1)) or Eats(Skol6(x2), x2))\n" ++-                                                                                        "(Person(x1) and Eats(x1, Skol2(x1)) and Food(x2)) -> (Person(Skol6(x2)))\n" ++-                                                                                        "(Person(x1) and Eats(x1, Skol2(x1)) and Food(x2)) -> (Eats(Skol6(x2), x2))"
− testsuite/tests/Data/Comp/Examples/Param.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Data.Comp.Examples.Param where--import Examples.Param.Names as Names-import Examples.Param.Graph as Graph--import Data.Comp.Param--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit-import Test.Utils----------------------------------------------------------------------------------------- Test Suits-----------------------------------------------------------------------------------tests = testGroup "Parametric Compositional Data Types" [-         testCase "names" namesTest,-         testCase "graph" graphTest-        ]-------------------------------------------------------------------------------------- Properties-----------------------------------------------------------------------------------instance (EqD f, PEq p) => EqD (f :&: p) where-    eqD (v1 :&: p1) (v2 :&: p2) = do b1 <- peq p1 p2-                                     b2 <- eqD v1 v2-                                     return $ b1 && b2--namesTest = sequence_ [en @=? en', ep @=? ep']-graphTest = sequence_ [n @=? 5, f @=? [0,2,1,2]]
testsuite/tests/Data/Comp/Examples_Test.hs view
@@ -3,17 +3,10 @@  import qualified Data.Comp.Examples.Comp as C import qualified Data.Comp.Examples.Multi as M-import qualified Data.Comp.Examples.Param as P-import qualified Data.Comp.Examples.MultiParam as MP  import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import Test.Utils  tests = testGroup "Examples" [          C.tests,-         M.tests,-         P.tests,-         MP.tests+         M.tests        ]
testsuite/tests/Data/Comp/Multi/Variables_Test.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, TypeOperators, FlexibleContexts , RankNTypes,-GADTs, ScopedTypeVariables, EmptyDataDecls#-}+GADTs, ScopedTypeVariables, EmptyDataDecls, ConstraintKinds #-}  module Data.Comp.Multi.Variables_Test where @@ -64,16 +64,16 @@     isVar (Var v) = Just v     isVar _       = Nothing     -    bindsVars (Abs v a) = Map.singleton (E a) (Set.singleton v)-    bindsVars _         = Map.empty+    bindsVars (Abs v a) = a |-> Set.singleton v+    bindsVars _         = empty  instance HasVars Op a where  instance HasVars Let Var where-    bindsVars (Let v _ a) = Map.singleton (E a) (Set.singleton v)+    bindsVars (Let v _ a) = a |-> Set.singleton v  instance HasVars LetRec Var where-    bindsVars (LetRec v a b) = Map.fromList [(E a,vs),(E b,vs)]+    bindsVars (LetRec v a b) = a |-> vs & b |-> vs         where vs = Set.singleton v  -- let x = x + 1 in (\y. y + x) z
+ testsuite/tests/Data/Comp/Subsume_Test.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TypeOperators, DataKinds, TypeFamilies #-}++-- | This module exports a dummy test to force type checking of this+-- module. In this module we test the subtyping system.++module Data.Comp.Subsume_Test where++import Data.Comp+import Data.Comp.Ops+import Data.Comp.SubsumeCommon+++import Test.Framework+import Test.Framework.Providers.QuickCheck2+++data S1 a = S1 a+data S2 a = S2 a+data S3 a = S3 a+data S4 a = S4 a++type TA = S1 :+: S2+type TB = S3 :+: S4+type T1 = TA :+: TB+type T2 = TB :+: TA+type T3 = S2 :+: TB++test1 :: ComprEmb (Elem T1 T1) ~ (Found Here) => Int+test1 = 1++test2 :: ComprEmb (Elem T1 T2) ~ (Found (Sum (Ri Here) (Le Here))) => Int+test2 = 1++test3 :: ComprEmb (Elem (T1 :+: S1) T2) ~ Ambiguous => Int+test3 = 1++test4 :: ComprEmb (Elem T1 (T2 :+: S1)) ~ Ambiguous => Int+test4 = 1++test5 :: ComprEmb (Elem T1 T3) ~ NotFound => Int+test5 = 1++test6 :: ComprEmb (Elem TB T1) ~ (Found (Ri Here)) => Int+test6 = 1++test7 :: ComprEmb (Elem T3 T1) ~ (Found (Sum (Le (Ri Here))(Ri Here))) => Int+test7 = 1++main = defaultMain [tests]++tests = testGroup "Subsume" [+         testProperty "prop_typecheck" prop_typecheck+        ]++-- dummy test+prop_typecheck = True
testsuite/tests/Data/Comp/Variables_Test.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE TemplateHaskell, TypeSynonymInstances,-FlexibleInstances, MultiParamTypeClasses, TypeOperators, FlexibleContexts#-}+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, +  TypeOperators, FlexibleContexts, ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}  module Data.Comp.Variables_Test where @@ -10,9 +11,7 @@ import Data.Comp.Term import Data.Comp.Show () -import Data.Map (Map) import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set  import Test.Framework@@ -31,13 +30,17 @@ data Val e = Abs Var e            | Var Var            | Int Int+  deriving Functor  data Op e = App e e           | Plus e e+  deriving Functor  data Let e = Let Var e e+  deriving Functor  data LetRec e = LetRec Var e e+  deriving Functor  type Sig = Op :+: Val @@ -45,7 +48,7 @@  type SigRec = LetRec :+: Sig -$(derive [makeFunctor, makeTraversable, makeFoldable,+$(derive [makeTraversable, makeFoldable,           makeEqF, makeShowF, smartConstructors]          [''Op, ''Val, ''Let, ''LetRec]) @@ -53,16 +56,16 @@     isVar (Var v) = Just v     isVar _       = Nothing     -    bindsVars (Abs v a) = Map.singleton a (Set.singleton v)-    bindsVars _         = Map.empty+    bindsVars (Abs v a) =  a |-> Set.singleton v+    bindsVars _         = empty  instance HasVars Op a where  instance HasVars Let Var where-    bindsVars (Let v _ a) = Map.singleton a (Set.singleton v)+    bindsVars (Let v _ a) = a |-> Set.singleton v  instance HasVars LetRec Var where-    bindsVars (LetRec v a b) = Map.fromList [(a,vs),(b,vs)]+    bindsVars (LetRec v a b) = a |-> vs & b |-> vs         where vs = Set.singleton v  -- let x = x + 1 in (\y. y + x) z
testsuite/tests/Data/Comp_Test.hs view
@@ -6,6 +6,7 @@ import qualified Data.Comp.Examples_Test import qualified Data.Comp.Variables_Test import qualified Data.Comp.Multi_Test+import qualified Data.Comp.Subsume_Test  -------------------------------------------------------------------------------- -- Test Suits@@ -17,7 +18,8 @@          Data.Comp.Equality_Test.tests,          Data.Comp.Examples_Test.tests,          Data.Comp.Variables_Test.tests,-         Data.Comp.Multi_Test.tests+         Data.Comp.Multi_Test.tests,+         Data.Comp.Subsume_Test.tests         ]  --------------------------------------------------------------------------------
testsuite/tests/Test/Utils.hs view
@@ -1,22 +1,23 @@-{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleContexts, FlexibleInstances, ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}  module Test.Utils where  import Data.Comp import Data.Comp.Derive -import Data.Foldable - data Tree l e = Leaf l               | UnNode l e               | BinNode e l e               | TerNode l e e e+              deriving Functor  data Pair a e = Pair a e+  deriving Functor  $(derive-  [makeFunctor, makeFoldable, makeShowF, makeEqF, makeArbitraryF]+  [makeFoldable, makeShowF, makeEqF, makeArbitraryF]   [''Tree, ''Pair])  $(derive