diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -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 diff --git a/benchmark/DataTypes.hs b/benchmark/DataTypes.hs --- a/benchmark/DataTypes.hs +++ b/benchmark/DataTypes.hs @@ -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 diff --git a/benchmark/DataTypes/Comp.hs b/benchmark/DataTypes/Comp.hs --- a/benchmark/DataTypes/Comp.hs +++ b/benchmark/DataTypes/Comp.hs @@ -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, diff --git a/benchmark/DataTypes/Standard.hs b/benchmark/DataTypes/Standard.hs --- a/benchmark/DataTypes/Standard.hs +++ b/benchmark/DataTypes/Standard.hs @@ -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]) diff --git a/benchmark/Functions/Comp/Desugar.hs b/benchmark/Functions/Comp/Desugar.hs --- a/benchmark/Functions/Comp/Desugar.hs +++ b/benchmark/Functions/Comp/Desugar.hs @@ -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 diff --git a/benchmark/Functions/Comp/Eval.hs b/benchmark/Functions/Comp/Eval.hs --- a/benchmark/Functions/Comp/Eval.hs +++ b/benchmark/Functions/Comp/Eval.hs @@ -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 diff --git a/benchmark/Functions/Comp/FreeVars.hs b/benchmark/Functions/Comp/FreeVars.hs --- a/benchmark/Functions/Comp/FreeVars.hs +++ b/benchmark/Functions/Comp/FreeVars.hs @@ -6,7 +6,8 @@ UndecidableInstances, TypeOperators, ScopedTypeVariables, - TypeSynonymInstances #-} + TypeSynonymInstances, + ConstraintKinds #-} module Functions.Comp.FreeVars where diff --git a/benchmark/Functions/Comp/HOAS.hs b/benchmark/Functions/Comp/HOAS.hs new file mode 100644 --- /dev/null +++ b/benchmark/Functions/Comp/HOAS.hs @@ -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 diff --git a/benchmark/Functions/Comp/Inference.hs b/benchmark/Functions/Comp/Inference.hs --- a/benchmark/Functions/Comp/Inference.hs +++ b/benchmark/Functions/Comp/Inference.hs @@ -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] diff --git a/benchmark/Functions/Standard/Eval.hs b/benchmark/Functions/Standard/Eval.hs --- a/benchmark/Functions/Standard/Eval.hs +++ b/benchmark/Functions/Standard/Eval.hs @@ -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) diff --git a/benchmark/Functions/Standard/FreeVars.hs b/benchmark/Functions/Standard/FreeVars.hs --- a/benchmark/Functions/Standard/FreeVars.hs +++ b/benchmark/Functions/Standard/FreeVars.hs @@ -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 diff --git a/benchmark/Functions/Standard/Inference.hs b/benchmark/Functions/Standard/Inference.hs --- a/benchmark/Functions/Standard/Inference.hs +++ b/benchmark/Functions/Standard/Inference.hs @@ -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) diff --git a/compdata.cabal b/compdata.cabal --- a/compdata.cabal +++ b/compdata.cabal @@ -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, - ), - 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, - ) 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 + + as outlined in the paper + . 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, - ). 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, - ). + * : + a parametric variant of compositional data types to deal with variable + binders in a systematic way. . + * : + advanced recursion schemes derived from tree automata that allow for a + higher degree of modularity and make it possible to apply fusion. + . + * : + 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 + diff --git a/examples/Examples/Automata/Compiler.hs b/examples/Examples/Automata/Compiler.hs deleted file mode 100644 --- a/examples/Examples/Automata/Compiler.hs +++ /dev/null @@ -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) diff --git a/examples/Examples/Common.hs b/examples/Examples/Common.hs --- a/examples/Examples/Common.hs +++ b/examples/Examples/Common.hs @@ -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]) diff --git a/examples/Examples/Desugar.hs b/examples/Examples/Desugar.hs --- a/examples/Examples/Desugar.hs +++ b/examples/Examples/Desugar.hs @@ -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]) diff --git a/examples/Examples/Eval.hs b/examples/Examples/Eval.hs --- a/examples/Examples/Eval.hs +++ b/examples/Examples/Eval.hs @@ -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 diff --git a/examples/Examples/EvalM.hs b/examples/Examples/EvalM.hs --- a/examples/Examples/EvalM.hs +++ b/examples/Examples/EvalM.hs @@ -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 diff --git a/examples/Examples/Multi/Desugar.hs b/examples/Examples/Multi/Desugar.hs --- a/examples/Examples/Multi/Desugar.hs +++ b/examples/Examples/Multi/Desugar.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs, - IncoherentInstances #-} + ConstraintKinds #-} -------------------------------------------------------------------------------- -- | -- Module : Examples.Multi.Desugar diff --git a/examples/Examples/Multi/Eval.hs b/examples/Examples/Multi/Eval.hs --- a/examples/Examples/Multi/Eval.hs +++ b/examples/Examples/Multi/Eval.hs @@ -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 diff --git a/examples/Examples/Multi/EvalM.hs b/examples/Examples/Multi/EvalM.hs --- a/examples/Examples/Multi/EvalM.hs +++ b/examples/Examples/Multi/EvalM.hs @@ -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 diff --git a/examples/Examples/MultiParam/FOL.hs b/examples/Examples/MultiParam/FOL.hs deleted file mode 100644 --- a/examples/Examples/MultiParam/FOL.hs +++ /dev/null @@ -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 --- 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 diff --git a/examples/Examples/MultiParam/Lambda.hs b/examples/Examples/MultiParam/Lambda.hs deleted file mode 100644 --- a/examples/Examples/MultiParam/Lambda.hs +++ /dev/null @@ -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 --- 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' diff --git a/examples/Examples/Param/Graph.hs b/examples/Examples/Param/Graph.hs deleted file mode 100644 --- a/examples/Examples/Param/Graph.hs +++ /dev/null @@ -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 --- 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 diff --git a/examples/Examples/Param/Lambda.hs b/examples/Examples/Param/Lambda.hs deleted file mode 100644 --- a/examples/Examples/Param/Lambda.hs +++ /dev/null @@ -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 --- 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' diff --git a/examples/Examples/Param/Names.hs b/examples/Examples/Param/Names.hs deleted file mode 100644 --- a/examples/Examples/Param/Names.hs +++ /dev/null @@ -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 --- 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' diff --git a/examples/Examples/Thunk.hs b/examples/Examples/Thunk.hs new file mode 100644 --- /dev/null +++ b/examples/Examples/Thunk.hs @@ -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 +-- 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) diff --git a/src/Data/Comp.hs b/src/Data/Comp.hs --- a/src/Data/Comp.hs +++ b/src/Data/Comp.hs @@ -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 diff --git a/src/Data/Comp/Algebra.hs b/src/Data/Comp/Algebra.hs --- a/src/Data/Comp/Algebra.hs +++ b/src/Data/Comp/Algebra.hs @@ -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 diff --git a/src/Data/Comp/Annotation.hs b/src/Data/Comp/Annotation.hs --- a/src/Data/Comp/Annotation.hs +++ b/src/Data/Comp/Annotation.hs @@ -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 -- 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 diff --git a/src/Data/Comp/Arbitrary.hs b/src/Data/Comp/Arbitrary.hs --- a/src/Data/Comp/Arbitrary.hs +++ b/src/Data/Comp/Arbitrary.hs @@ -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 diff --git a/src/Data/Comp/Automata.hs b/src/Data/Comp/Automata.hs deleted file mode 100644 --- a/src/Data/Comp/Automata.hs +++ /dev/null @@ -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 --- 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, ). --- --------------------------------------------------------------------------------- - -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' diff --git a/src/Data/Comp/Automata/Product.hs b/src/Data/Comp/Automata/Product.hs deleted file mode 100644 --- a/src/Data/Comp/Automata/Product.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/Automata/Product/Derive.hs b/src/Data/Comp/Automata/Product/Derive.hs deleted file mode 100644 --- a/src/Data/Comp/Automata/Product/Derive.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Comp/Decompose.hs b/src/Data/Comp/Decompose.hs --- a/src/Data/Comp/Decompose.hs +++ b/src/Data/Comp/Decompose.hs @@ -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 diff --git a/src/Data/Comp/DeepSeq.hs b/src/Data/Comp/DeepSeq.hs --- a/src/Data/Comp/DeepSeq.hs +++ b/src/Data/Comp/DeepSeq.hs @@ -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, ''[], ''(,)]) diff --git a/src/Data/Comp/Derive.hs b/src/Data/Comp/Derive.hs --- a/src/Data/Comp/Derive.hs +++ b/src/Data/Comp/Derive.hs @@ -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 diff --git a/src/Data/Comp/Derive/Arbitrary.hs b/src/Data/Comp/Derive/Arbitrary.hs --- a/src/Data/Comp/Derive/Arbitrary.hs +++ b/src/Data/Comp/Derive/Arbitrary.hs @@ -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: - + @ \ :: Gen \ \ = ... @@ -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)) [] diff --git a/src/Data/Comp/Derive/DeepSeq.hs b/src/Data/Comp/Derive/DeepSeq.hs --- a/src/Data/Comp/Derive/DeepSeq.hs +++ b/src/Data/Comp/Derive/DeepSeq.hs @@ -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) [] diff --git a/src/Data/Comp/Derive/Equality.hs b/src/Data/Comp/Derive/Equality.hs --- a/src/Data/Comp/Derive/Equality.hs +++ b/src/Data/Comp/Derive/Equality.hs @@ -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) [] diff --git a/src/Data/Comp/Derive/Foldable.hs b/src/Data/Comp/Derive/Foldable.hs --- a/src/Data/Comp/Derive/Foldable.hs +++ b/src/Data/Comp/Derive/Foldable.hs @@ -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) [] diff --git a/src/Data/Comp/Derive/HaskellStrict.hs b/src/Data/Comp/Derive/HaskellStrict.hs --- a/src/Data/Comp/Derive/HaskellStrict.hs +++ b/src/Data/Comp/Derive/HaskellStrict.hs @@ -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 diff --git a/src/Data/Comp/Derive/Injections.hs b/src/Data/Comp/Derive/Injections.hs deleted file mode 100644 --- a/src/Data/Comp/Derive/Injections.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Derive.Injections --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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) |] diff --git a/src/Data/Comp/Derive/Ordering.hs b/src/Data/Comp/Derive/Ordering.hs --- a/src/Data/Comp/Derive/Ordering.hs +++ b/src/Data/Comp/Derive/Ordering.hs @@ -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) diff --git a/src/Data/Comp/Derive/Projections.hs b/src/Data/Comp/Derive/Projections.hs deleted file mode 100644 --- a/src/Data/Comp/Derive/Projections.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE TemplateHaskell, GADTs #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Derive.Projections --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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) |] diff --git a/src/Data/Comp/Derive/Show.hs b/src/Data/Comp/Derive/Show.hs --- a/src/Data/Comp/Derive/Show.hs +++ b/src/Data/Comp/Derive/Show.hs @@ -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) [] diff --git a/src/Data/Comp/Derive/SmartAConstructors.hs b/src/Data/Comp/Derive/SmartAConstructors.hs --- a/src/Data/Comp/Derive/SmartAConstructors.hs +++ b/src/Data/Comp/Derive/SmartAConstructors.hs @@ -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) diff --git a/src/Data/Comp/Derive/SmartConstructors.hs b/src/Data/Comp/Derive/SmartConstructors.hs --- a/src/Data/Comp/Derive/SmartConstructors.hs +++ b/src/Data/Comp/Derive/SmartConstructors.hs @@ -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 _ _ _ _ = [] diff --git a/src/Data/Comp/Derive/Traversable.hs b/src/Data/Comp/Derive/Traversable.hs --- a/src/Data/Comp/Derive/Traversable.hs +++ b/src/Data/Comp/Derive/Traversable.hs @@ -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 diff --git a/src/Data/Comp/Derive/Utils.hs b/src/Data/Comp/Derive/Utils.hs --- a/src/Data/Comp/Derive/Utils.hs +++ b/src/Data/Comp/Derive/Utils.hs @@ -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) diff --git a/src/Data/Comp/Desugar.hs b/src/Data/Comp/Desugar.hs --- a/src/Data/Comp/Desugar.hs +++ b/src/Data/Comp/Desugar.hs @@ -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 diff --git a/src/Data/Comp/Equality.hs b/src/Data/Comp/Equality.hs --- a/src/Data/Comp/Equality.hs +++ b/src/Data/Comp/Equality.hs @@ -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 diff --git a/src/Data/Comp/Generic.hs b/src/Data/Comp/Generic.hs --- a/src/Data/Comp/Generic.hs +++ b/src/Data/Comp/Generic.hs @@ -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 diff --git a/src/Data/Comp/Mapping.hs b/src/Data/Comp/Mapping.hs new file mode 100644 --- /dev/null +++ b/src/Data/Comp/Mapping.hs @@ -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 +-- 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) diff --git a/src/Data/Comp/Matching.hs b/src/Data/Comp/Matching.hs --- a/src/Data/Comp/Matching.hs +++ b/src/Data/Comp/Matching.hs @@ -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 diff --git a/src/Data/Comp/Multi.hs b/src/Data/Comp/Multi.hs --- a/src/Data/Comp/Multi.hs +++ b/src/Data/Comp/Multi.hs @@ -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) diff --git a/src/Data/Comp/Multi/Algebra.hs b/src/Data/Comp/Multi/Algebra.hs --- a/src/Data/Comp/Multi/Algebra.hs +++ b/src/Data/Comp/Multi/Algebra.hs @@ -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 diff --git a/src/Data/Comp/Multi/Annotation.hs b/src/Data/Comp/Multi/Annotation.hs --- a/src/Data/Comp/Multi/Annotation.hs +++ b/src/Data/Comp/Multi/Annotation.hs @@ -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 diff --git a/src/Data/Comp/Multi/Derive.hs b/src/Data/Comp/Multi/Derive.hs --- a/src/Data/Comp/Multi/Derive.hs +++ b/src/Data/Comp/Multi/Derive.hs @@ -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 diff --git a/src/Data/Comp/Multi/Derive/Equality.hs b/src/Data/Comp/Multi/Derive/Equality.hs --- a/src/Data/Comp/Multi/Derive/Equality.hs +++ b/src/Data/Comp/Multi/Derive/Equality.hs @@ -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) [] diff --git a/src/Data/Comp/Multi/Derive/HFoldable.hs b/src/Data/Comp/Multi/Derive/HFoldable.hs --- a/src/Data/Comp/Multi/Derive/HFoldable.hs +++ b/src/Data/Comp/Multi/Derive/HFoldable.hs @@ -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) = diff --git a/src/Data/Comp/Multi/Derive/HFunctor.hs b/src/Data/Comp/Multi/Derive/HFunctor.hs --- a/src/Data/Comp/Multi/Derive/HFunctor.hs +++ b/src/Data/Comp/Multi/Derive/HFunctor.hs @@ -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, diff --git a/src/Data/Comp/Multi/Derive/HTraversable.hs b/src/Data/Comp/Multi/Derive/HTraversable.hs --- a/src/Data/Comp/Multi/Derive/HTraversable.hs +++ b/src/Data/Comp/Multi/Derive/HTraversable.hs @@ -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" diff --git a/src/Data/Comp/Multi/Derive/Injections.hs b/src/Data/Comp/Multi/Derive/Injections.hs deleted file mode 100644 --- a/src/Data/Comp/Multi/Derive/Injections.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Multi.Derive.Injections --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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) |] diff --git a/src/Data/Comp/Multi/Derive/Ordering.hs b/src/Data/Comp/Multi/Derive/Ordering.hs --- a/src/Data/Comp/Multi/Derive/Ordering.hs +++ b/src/Data/Comp/Multi/Derive/Ordering.hs @@ -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 |]) [] diff --git a/src/Data/Comp/Multi/Derive/Projections.hs b/src/Data/Comp/Multi/Derive/Projections.hs deleted file mode 100644 --- a/src/Data/Comp/Multi/Derive/Projections.hs +++ /dev/null @@ -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 --- 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) |] diff --git a/src/Data/Comp/Multi/Derive/Show.hs b/src/Data/Comp/Multi/Derive/Show.hs --- a/src/Data/Comp/Multi/Derive/Show.hs +++ b/src/Data/Comp/Multi/Derive/Show.hs @@ -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|] diff --git a/src/Data/Comp/Multi/Derive/SmartAConstructors.hs b/src/Data/Comp/Multi/Derive/SmartAConstructors.hs --- a/src/Data/Comp/Multi/Derive/SmartAConstructors.hs +++ b/src/Data/Comp/Multi/Derive/SmartAConstructors.hs @@ -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) diff --git a/src/Data/Comp/Multi/Derive/SmartConstructors.hs b/src/Data/Comp/Multi/Derive/SmartConstructors.hs --- a/src/Data/Comp/Multi/Derive/SmartConstructors.hs +++ b/src/Data/Comp/Multi/Derive/SmartConstructors.hs @@ -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 _ _ _ _ _ = [] diff --git a/src/Data/Comp/Multi/Desugar.hs b/src/Data/Comp/Multi/Desugar.hs --- a/src/Data/Comp/Multi/Desugar.hs +++ b/src/Data/Comp/Multi/Desugar.hs @@ -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 diff --git a/src/Data/Comp/Multi/Equality.hs b/src/Data/Comp/Multi/Equality.hs --- a/src/Data/Comp/Multi/Equality.hs +++ b/src/Data/Comp/Multi/Equality.hs @@ -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 diff --git a/src/Data/Comp/Multi/Generic.hs b/src/Data/Comp/Multi/Generic.hs --- a/src/Data/Comp/Multi/Generic.hs +++ b/src/Data/Comp/Multi/Generic.hs @@ -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 diff --git a/src/Data/Comp/Multi/HFoldable.hs b/src/Data/Comp/Multi/HFoldable.hs --- a/src/Data/Comp/Multi/HFoldable.hs +++ b/src/Data/Comp/Multi/HFoldable.hs @@ -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) diff --git a/src/Data/Comp/Multi/HFunctor.hs b/src/Data/Comp/Multi/HFunctor.hs --- a/src/Data/Comp/Multi/HFunctor.hs +++ b/src/Data/Comp/Multi/HFunctor.hs @@ -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) diff --git a/src/Data/Comp/Multi/HTraversable.hs b/src/Data/Comp/Multi/HTraversable.hs --- a/src/Data/Comp/Multi/HTraversable.hs +++ b/src/Data/Comp/Multi/HTraversable.hs @@ -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) diff --git a/src/Data/Comp/Multi/Mapping.hs b/src/Data/Comp/Multi/Mapping.hs new file mode 100644 --- /dev/null +++ b/src/Data/Comp/Multi/Mapping.hs @@ -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 +-- 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) diff --git a/src/Data/Comp/Multi/Number.hs b/src/Data/Comp/Multi/Number.hs deleted file mode 100644 --- a/src/Data/Comp/Multi/Number.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Multi.Number --- Copyright : (c) 2012 Patrick Bahr --- License : BSD3 --- Maintainer : Patrick Bahr --- 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) diff --git a/src/Data/Comp/Multi/Ops.hs b/src/Data/Comp/Multi/Ops.hs --- a/src/Data/Comp/Multi/Ops.hs +++ b/src/Data/Comp/Multi/Ops.hs @@ -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 diff --git a/src/Data/Comp/Multi/Ordering.hs b/src/Data/Comp/Multi/Ordering.hs --- a/src/Data/Comp/Multi/Ordering.hs +++ b/src/Data/Comp/Multi/Ordering.hs @@ -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 diff --git a/src/Data/Comp/Multi/Projection.hs b/src/Data/Comp/Multi/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Comp/Multi/Projection.hs @@ -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 +-- 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))) diff --git a/src/Data/Comp/Multi/Show.hs b/src/Data/Comp/Multi/Show.hs --- a/src/Data/Comp/Multi/Show.hs +++ b/src/Data/Comp/Multi/Show.hs @@ -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 diff --git a/src/Data/Comp/Multi/Sum.hs b/src/Data/Comp/Multi/Sum.hs --- a/src/Data/Comp/Multi/Sum.hs +++ b/src/Data/Comp/Multi/Sum.hs @@ -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 diff --git a/src/Data/Comp/Multi/Term.hs b/src/Data/Comp/Multi/Term.hs --- a/src/Data/Comp/Multi/Term.hs +++ b/src/Data/Comp/Multi/Term.hs @@ -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 diff --git a/src/Data/Comp/Multi/Variables.hs b/src/Data/Comp/Multi/Variables.hs --- a/src/Data/Comp/Multi/Variables.hs +++ b/src/Data/Comp/Multi/Variables.hs @@ -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)) diff --git a/src/Data/Comp/MultiParam.hs b/src/Data/Comp/MultiParam.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam.hs +++ /dev/null @@ -1,34 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.MultiParam --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Patrick Bahr , Tom Hvitved --- 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 diff --git a/src/Data/Comp/MultiParam/Algebra.hs b/src/Data/Comp/MultiParam/Algebra.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Algebra.hs +++ /dev/null @@ -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 --- 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 --} diff --git a/src/Data/Comp/MultiParam/Annotation.hs b/src/Data/Comp/MultiParam/Annotation.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Annotation.hs +++ /dev/null @@ -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 --- 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)) diff --git a/src/Data/Comp/MultiParam/Derive.hs b/src/Data/Comp/MultiParam/Derive.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.MultiParam.Derive --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 ''(:+:) diff --git a/src/Data/Comp/MultiParam/Derive/Equality.hs b/src/Data/Comp/MultiParam/Derive/Equality.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/Equality.hs +++ /dev/null @@ -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 --- 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) |] diff --git a/src/Data/Comp/MultiParam/Derive/HDifunctor.hs b/src/Data/Comp/MultiParam/Derive/HDifunctor.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/HDifunctor.hs +++ /dev/null @@ -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 --- 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 |] diff --git a/src/Data/Comp/MultiParam/Derive/Injections.hs b/src/Data/Comp/MultiParam/Derive/Injections.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/Injections.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.MultiParam.Derive.Injections --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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) |] diff --git a/src/Data/Comp/MultiParam/Derive/Ordering.hs b/src/Data/Comp/MultiParam/Derive/Ordering.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/Ordering.hs +++ /dev/null @@ -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 --- 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 |]) [] diff --git a/src/Data/Comp/MultiParam/Derive/Projections.hs b/src/Data/Comp/MultiParam/Derive/Projections.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/Projections.hs +++ /dev/null @@ -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 --- 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) |] diff --git a/src/Data/Comp/MultiParam/Derive/Show.hs b/src/Data/Comp/MultiParam/Derive/Show.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/Show.hs +++ /dev/null @@ -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 --- 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) |] diff --git a/src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs b/src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.MultiParam.Derive.SmartAConstructors --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 diff --git a/src/Data/Comp/MultiParam/Derive/SmartConstructors.hs b/src/Data/Comp/MultiParam/Derive/SmartConstructors.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Derive/SmartConstructors.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.MultiParam.Derive.SmartConstructors --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 _ _ _ _ _ = [] diff --git a/src/Data/Comp/MultiParam/Desugar.hs b/src/Data/Comp/MultiParam/Desugar.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Desugar.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/MultiParam/Equality.hs b/src/Data/Comp/MultiParam/Equality.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Equality.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/MultiParam/FreshM.hs b/src/Data/Comp/MultiParam/FreshM.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/FreshM.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.MultiParam.FreshM --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 diff --git a/src/Data/Comp/MultiParam/HDifunctor.hs b/src/Data/Comp/MultiParam/HDifunctor.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/HDifunctor.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/MultiParam/HDitraversable.hs b/src/Data/Comp/MultiParam/HDitraversable.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/HDitraversable.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Comp/MultiParam/Ops.hs b/src/Data/Comp/MultiParam/Ops.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Ops.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/MultiParam/Ordering.hs b/src/Data/Comp/MultiParam/Ordering.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Ordering.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/MultiParam/Show.hs b/src/Data/Comp/MultiParam/Show.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Show.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/MultiParam/Sum.hs b/src/Data/Comp/MultiParam/Sum.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Sum.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/MultiParam/Term.hs b/src/Data/Comp/MultiParam/Term.hs deleted file mode 100644 --- a/src/Data/Comp/MultiParam/Term.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Comp/Number.hs b/src/Data/Comp/Number.hs deleted file mode 100644 --- a/src/Data/Comp/Number.hs +++ /dev/null @@ -1,45 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Number --- Copyright : (c) 2012 Patrick Bahr --- License : BSD3 --- Maintainer : Patrick Bahr --- 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) diff --git a/src/Data/Comp/Ops.hs b/src/Data/Comp/Ops.hs --- a/src/Data/Comp/Ops.hs +++ b/src/Data/Comp/Ops.hs @@ -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 diff --git a/src/Data/Comp/Ordering.hs b/src/Data/Comp/Ordering.hs --- a/src/Data/Comp/Ordering.hs +++ b/src/Data/Comp/Ordering.hs @@ -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 diff --git a/src/Data/Comp/Param.hs b/src/Data/Comp/Param.hs deleted file mode 100644 --- a/src/Data/Comp/Param.hs +++ /dev/null @@ -1,32 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Patrick Bahr , Tom Hvitved --- 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 diff --git a/src/Data/Comp/Param/Algebra.hs b/src/Data/Comp/Param/Algebra.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Algebra.hs +++ /dev/null @@ -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 --- 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 --} diff --git a/src/Data/Comp/Param/Annotation.hs b/src/Data/Comp/Param/Annotation.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Annotation.hs +++ /dev/null @@ -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 --- 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))) diff --git a/src/Data/Comp/Param/Derive.hs b/src/Data/Comp/Param/Derive.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Derive --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 ''(:+:) diff --git a/src/Data/Comp/Param/Derive/Difunctor.hs b/src/Data/Comp/Param/Derive/Difunctor.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/Difunctor.hs +++ /dev/null @@ -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 --- 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 |] diff --git a/src/Data/Comp/Param/Derive/Ditraversable.hs b/src/Data/Comp/Param/Derive/Ditraversable.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/Ditraversable.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Derive.Ditraversable --- Copyright : (c) 2010-2011 Patrick Bahr --- License : BSD3 --- Maintainer : Patrick Bahr --- 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) [] diff --git a/src/Data/Comp/Param/Derive/Equality.hs b/src/Data/Comp/Param/Derive/Equality.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/Equality.hs +++ /dev/null @@ -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 --- 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) |] diff --git a/src/Data/Comp/Param/Derive/Injections.hs b/src/Data/Comp/Param/Derive/Injections.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/Injections.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Derive.Injections --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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) |] diff --git a/src/Data/Comp/Param/Derive/Ordering.hs b/src/Data/Comp/Param/Derive/Ordering.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/Ordering.hs +++ /dev/null @@ -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 --- 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 |]) [] diff --git a/src/Data/Comp/Param/Derive/Projections.hs b/src/Data/Comp/Param/Derive/Projections.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/Projections.hs +++ /dev/null @@ -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 --- 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) |] diff --git a/src/Data/Comp/Param/Derive/Show.hs b/src/Data/Comp/Param/Derive/Show.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/Show.hs +++ /dev/null @@ -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 --- 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) |] diff --git a/src/Data/Comp/Param/Derive/SmartAConstructors.hs b/src/Data/Comp/Param/Derive/SmartAConstructors.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/SmartAConstructors.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Derive.SmartAConstructors --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 diff --git a/src/Data/Comp/Param/Derive/SmartConstructors.hs b/src/Data/Comp/Param/Derive/SmartConstructors.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Derive/SmartConstructors.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Derive.SmartConstructors --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 _ _ _ _ = [] diff --git a/src/Data/Comp/Param/Desugar.hs b/src/Data/Comp/Param/Desugar.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Desugar.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/Param/Difunctor.hs b/src/Data/Comp/Param/Difunctor.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Difunctor.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Difunctor --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 diff --git a/src/Data/Comp/Param/Ditraversable.hs b/src/Data/Comp/Param/Ditraversable.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Ditraversable.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Ditraversable --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 diff --git a/src/Data/Comp/Param/Equality.hs b/src/Data/Comp/Param/Equality.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Equality.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/Param/FreshM.hs b/src/Data/Comp/Param/FreshM.hs deleted file mode 100644 --- a/src/Data/Comp/Param/FreshM.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.FreshM --- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved --- License : BSD3 --- Maintainer : Tom Hvitved --- 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 diff --git a/src/Data/Comp/Param/Ops.hs b/src/Data/Comp/Param/Ops.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Ops.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Comp/Param/Ordering.hs b/src/Data/Comp/Param/Ordering.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Ordering.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/Param/Show.hs b/src/Data/Comp/Param/Show.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Show.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/Param/Sum.hs b/src/Data/Comp/Param/Sum.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Sum.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Data/Comp/Param/Term.hs b/src/Data/Comp/Param/Term.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Term.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Data/Comp/Param/Thunk.hs b/src/Data/Comp/Param/Thunk.hs deleted file mode 100644 --- a/src/Data/Comp/Param/Thunk.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE TypeOperators, FlexibleContexts, Rank2Types, GADTs #-} - --------------------------------------------------------------------------------- --- | --- Module : Data.Comp.Param.Thunk --- Copyright : (c) 2011 Patrick Bahr --- License : BSD3 --- Maintainer : Patrick Bahr --- 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 diff --git a/src/Data/Comp/Projection.hs b/src/Data/Comp/Projection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Comp/Projection.hs @@ -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 +-- 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))) diff --git a/src/Data/Comp/Render.hs b/src/Data/Comp/Render.hs new file mode 100644 --- /dev/null +++ b/src/Data/Comp/Render.hs @@ -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]) diff --git a/src/Data/Comp/Show.hs b/src/Data/Comp/Show.hs --- a/src/Data/Comp/Show.hs +++ b/src/Data/Comp/Show.hs @@ -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]) diff --git a/src/Data/Comp/SubsumeCommon.hs b/src/Data/Comp/SubsumeCommon.hs new file mode 100644 --- /dev/null +++ b/src/Data/Comp/SubsumeCommon.hs @@ -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 +-- 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 diff --git a/src/Data/Comp/Sum.hs b/src/Data/Comp/Sum.hs --- a/src/Data/Comp/Sum.hs +++ b/src/Data/Comp/Sum.hs @@ -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 diff --git a/src/Data/Comp/Term.hs b/src/Data/Comp/Term.hs --- a/src/Data/Comp/Term.hs +++ b/src/Data/Comp/Term.hs @@ -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 diff --git a/src/Data/Comp/TermRewriting.hs b/src/Data/Comp/TermRewriting.hs --- a/src/Data/Comp/TermRewriting.hs +++ b/src/Data/Comp/TermRewriting.hs @@ -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. -} diff --git a/src/Data/Comp/Thunk.hs b/src/Data/Comp/Thunk.hs --- a/src/Data/Comp/Thunk.hs +++ b/src/Data/Comp/Thunk.hs @@ -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 diff --git a/src/Data/Comp/Unification.hs b/src/Data/Comp/Unification.hs --- a/src/Data/Comp/Unification.hs +++ b/src/Data/Comp/Unification.hs @@ -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 diff --git a/src/Data/Comp/Variables.hs b/src/Data/Comp/Variables.hs --- a/src/Data/Comp/Variables.hs +++ b/src/Data/Comp/Variables.hs @@ -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 diff --git a/testsuite/tests/Data/Comp/Equality_Test.hs b/testsuite/tests/Data/Comp/Equality_Test.hs --- a/testsuite/tests/Data/Comp/Equality_Test.hs +++ b/testsuite/tests/Data/Comp/Equality_Test.hs @@ -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) diff --git a/testsuite/tests/Data/Comp/Examples/Comp.hs b/testsuite/tests/Data/Comp/Examples/Comp.hs --- a/testsuite/tests/Data/Comp/Examples/Comp.hs +++ b/testsuite/tests/Data/Comp/Examples/Comp.hs @@ -11,10 +11,6 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit -import Test.Utils hiding (iPair) - - - -------------------------------------------------------------------------------- diff --git a/testsuite/tests/Data/Comp/Examples/Multi.hs b/testsuite/tests/Data/Comp/Examples/Multi.hs --- a/testsuite/tests/Data/Comp/Examples/Multi.hs +++ b/testsuite/tests/Data/Comp/Examples/Multi.hs @@ -12,7 +12,6 @@ import Test.Framework import Test.Framework.Providers.HUnit import Test.HUnit -import Test.Utils hiding (iPair) -------------------------------------------------------------------------------- -- Test Suits diff --git a/testsuite/tests/Data/Comp/Examples/MultiParam.hs b/testsuite/tests/Data/Comp/Examples/MultiParam.hs deleted file mode 100644 --- a/testsuite/tests/Data/Comp/Examples/MultiParam.hs +++ /dev/null @@ -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))" diff --git a/testsuite/tests/Data/Comp/Examples/Param.hs b/testsuite/tests/Data/Comp/Examples/Param.hs deleted file mode 100644 --- a/testsuite/tests/Data/Comp/Examples/Param.hs +++ /dev/null @@ -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]] diff --git a/testsuite/tests/Data/Comp/Examples_Test.hs b/testsuite/tests/Data/Comp/Examples_Test.hs --- a/testsuite/tests/Data/Comp/Examples_Test.hs +++ b/testsuite/tests/Data/Comp/Examples_Test.hs @@ -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 ] diff --git a/testsuite/tests/Data/Comp/Multi/Variables_Test.hs b/testsuite/tests/Data/Comp/Multi/Variables_Test.hs --- a/testsuite/tests/Data/Comp/Multi/Variables_Test.hs +++ b/testsuite/tests/Data/Comp/Multi/Variables_Test.hs @@ -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 diff --git a/testsuite/tests/Data/Comp/Subsume_Test.hs b/testsuite/tests/Data/Comp/Subsume_Test.hs new file mode 100644 --- /dev/null +++ b/testsuite/tests/Data/Comp/Subsume_Test.hs @@ -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 diff --git a/testsuite/tests/Data/Comp/Variables_Test.hs b/testsuite/tests/Data/Comp/Variables_Test.hs --- a/testsuite/tests/Data/Comp/Variables_Test.hs +++ b/testsuite/tests/Data/Comp/Variables_Test.hs @@ -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 diff --git a/testsuite/tests/Data/Comp_Test.hs b/testsuite/tests/Data/Comp_Test.hs --- a/testsuite/tests/Data/Comp_Test.hs +++ b/testsuite/tests/Data/Comp_Test.hs @@ -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 ] -------------------------------------------------------------------------------- diff --git a/testsuite/tests/Test/Utils.hs b/testsuite/tests/Test/Utils.hs --- a/testsuite/tests/Test/Utils.hs +++ b/testsuite/tests/Test/Utils.hs @@ -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