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 @@ -45,7 +45,7 @@ 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), @@ -97,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), 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 @@ -20,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 +35,6 @@ desug' :: Desug f e => Term f -> Term e {-# INLINE desug' #-} desug' = appHom' desugAlg - -$(derive [liftSum] [''Desug]) instance (Value :<: v, Functor v) => Desug Value v where desugAlg = liftCxt 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 @@ -30,11 +30,11 @@ 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 :<: m :+: v) => EvalT Value v m where evalTAlg = inject @@ -100,11 +100,11 @@ 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 @@ -150,14 +150,14 @@ 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 (Term x) = evalDir x evalDirectE :: SugarExpr -> Err ValueExpr evalDirectE = evalDirect -$(derive [liftSum] [''EvalDir]) - instance (MonadFail m) => EvalDir Value m where evalDir (VInt i) = return $ iVInt i evalDir (VBool i) = return $ iVBool i @@ -213,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 @@ -264,13 +264,13 @@ class EvalDir2 e where evalDir2 :: (EvalDir2 f) => e (Term f) -> ValueExpr +$(derive [liftSum] [''EvalDir2]) + evalDirect2 :: (EvalDir2 e) => Term e -> ValueExpr 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/compdata.cabal b/compdata.cabal --- a/compdata.cabal +++ b/compdata.cabal @@ -1,13 +1,12 @@ Name: compdata -Version: 0.12.1 +Version: 0.13.1 Synopsis: Compositional Data Types Description: - This library implements the ideas of /Data types a la carte/ - (Journal of Functional Programming, 18(4):423-436, 2008, - ) as outlined in the - paper /Compositional data types/ (Workshop on Generic Programming, - 83-94, 2011, ). The + 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 @@ -77,19 +76,16 @@ There are some supplementary packages, some of which were included in previous versions of this package: . - * @compdata-param@ - : a parametric - variant of compositional data types to deal with variable binders - in a systematic way. + * : + a parametric variant of compositional data types to deal with variable + binders in a systematic way. . - * @compdata-automata@ - : advanced - recursion schemes derived from tree automata that allow for a + * : + advanced recursion schemes derived from tree automata that allow for a higher degree of modularity and make it possible to apply fusion. . - * @compdata-dags@ - : recursion - schemes on directed acyclic graphs. + * : + recursion schemes on directed acyclic graphs. Category: Generics @@ -98,10 +94,11 @@ Author: Patrick Bahr, Tom Hvitved Maintainer: paba@itu.dk Build-Type: Simple -Cabal-Version: >=1.12 +Cabal-Version: >=1.9.2 bug-reports: https://github.com/pa-ba/compdata/issues extra-source-files: + CHANGELOG.md -- test files testsuite/tests/*.hs testsuite/tests/Data/*.hs @@ -190,10 +187,17 @@ - Build-Depends: base >= 4.9, base < 5, template-haskell, containers, mtl >= 2.2.1, - QuickCheck >= 2, deepseq, transformers, th-expand-syns, - tree-view >= 0.5 - Default-Language: Haskell2010 + 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 @@ -203,9 +207,10 @@ Type: exitcode-stdio-1.0 Main-is: Data_Test.hs hs-source-dirs: testsuite/tests examples src - Build-Depends: base >= 4.9, base < 5, template-haskell, containers, mtl >= 2.2.1, + 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: @@ -282,7 +287,7 @@ Examples.Multi.EvalI Examples.Multi.EvalM Test.Utils - Default-Language: Haskell2010 + Benchmark algebra Type: exitcode-stdio-1.0 @@ -291,9 +296,10 @@ 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.9, base < 5, template-haskell, containers, mtl >= 2.2.1, + 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 @@ -337,8 +343,7 @@ Functions.Standard.Eval Functions.Standard.FreeVars Functions.Standard.Inference - Default-Language: Haskell2010 - + source-repository head type: git location: https://github.com/pa-ba/compdata 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 @@ -38,7 +38,7 @@ 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 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 @@ -114,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 @@ -44,7 +44,7 @@ genRnfFClause (constr, args,_) = do let n = length args varNs <- newNames n "x" - let pat = ConP constr $ map VarP 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 @@ -46,8 +46,8 @@ 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/Foldable.hs b/src/Data/Comp/Derive/Foldable.hs --- a/src/Data/Comp/Derive/Foldable.hs +++ b/src/Data/Comp/Derive/Foldable.hs @@ -57,7 +57,7 @@ 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) = 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 @@ -92,7 +92,7 @@ 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" 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 @@ -56,8 +56,8 @@ 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/Show.hs b/src/Data/Comp/Derive/Show.hs --- a/src/Data/Comp/Derive/Show.hs +++ b/src/Data/Comp/Derive/Show.hs @@ -54,7 +54,7 @@ genShowFClause fArg (constr, args, gadtTy) = do let n = length args varNs <- newNames n "x" - let pat = ConP constr $ map VarP varNs + let pat = ConP constr [] $ map VarP varNs allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs shows = listE $ map mkShow allVars conName = nameBase constr @@ -90,7 +90,7 @@ genShowConstrClause fArg (constr, args, gadtTy) = do let n = length args varNs <- newNames n "x" - let pat = ConP constr $ map VarP varNs + let pat = ConP constr [] $ map VarP varNs allVars = zipWith (filterFarg (getUnaryFArg fArg gadtTy)) args varNs shows = listE $ map mkShow allVars conName = nameBase constr 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 @@ -54,6 +54,6 @@ ftype = foldl appT (conT tname) (map varT targs') 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 @@ -55,7 +55,7 @@ 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/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 #-} -------------------------------------------------------------------------------- -- | @@ -20,21 +21,8 @@ import Language.Haskell.TH.Syntax 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] -#if __GLASGOW_HASKELL__ < 800 -data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] [Name] -#else -#if __GLASGOW_HASKELL__ < 802 -data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] Cxt -#else -data DataInfo = DataInfo Cxt Name [TyVarBndr] [Con] [DerivClause] -#endif -#endif {-| This is the @Q@-lifted version of 'abstractNewtype. @@ -47,17 +35,10 @@ @data@ declarations. -} abstractNewtype :: Info -> Maybe DataInfo -#if __GLASGOW_HASKELL__ < 800 -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) -#else 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) -#endif abstractNewtype _ = Nothing {-| This function provides the name and the arity of the given data @@ -68,9 +49,7 @@ 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 -#if __GLASGOW_HASKELL__ >= 800 normalCon (GadtC (constr:_) args typ) = (constr,args,Just typ) -#endif normalCon _ = error "missing case for 'normalCon'" normalCon' :: Con -> (Name,[Type], Maybe Type) @@ -126,16 +105,14 @@ abstractConType (RecC constr args) = (constr, length args) abstractConType (InfixC _ constr _) = (constr, 2) abstractConType (ForallC _ _ constr) = abstractConType constr -#if __GLASGOW_HASKELL__ >= 800 abstractConType (GadtC (constr:_) args _typ) = (constr,length args) -- Only first Name -#endif 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 @@ -181,34 +158,19 @@ constraint. -} -#if __GLASGOW_HASKELL__ < 710 -mkClassP :: Name -> [Type] -> Pred -mkClassP = ClassP -#else mkClassP :: Name -> [Type] -> Type mkClassP name = foldl AppT (ConT name) -#endif {-| This function checks whether the given type constraint is an equality constraint. If so, the types of the equality constraint are returned. -} -#if __GLASGOW_HASKELL__ < 710 -isEqualP :: Pred -> Maybe (Type, Type) -isEqualP (EqualP x y) = Just (x, y) -isEqualP _ = Nothing -#else isEqualP :: Type -> Maybe (Type, Type) isEqualP (AppT (AppT EqualityT x) y) = Just (x, y) isEqualP _ = Nothing -#endif mkInstanceD :: Cxt -> Type -> [Dec] -> Dec -#if __GLASGOW_HASKELL__ < 800 -mkInstanceD cxt ty decs = InstanceD cxt ty decs -#else mkInstanceD cxt ty decs = InstanceD Nothing cxt ty decs -#endif 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,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} 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 @@ -38,7 +38,7 @@ 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 [] = Just $ Term $ fmap ((fromJust) . ($ [])) t alg t (i:is) = case drop i (toList t) of [] -> Nothing x : _ -> x is diff --git a/src/Data/Comp/Mapping.hs b/src/Data/Comp/Mapping.hs --- a/src/Data/Comp/Mapping.hs +++ b/src/Data/Comp/Mapping.hs @@ -35,7 +35,7 @@ import Data.Traversable import Data.Foldable -import Control.Monad.State hiding (mapM) +import Control.Monad.State import Prelude hiding (mapM) 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 @@ -91,6 +91,8 @@ import Control.Monad +import Data.Kind + import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable import Data.Comp.Multi.Term @@ -164,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) @@ -229,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. 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 @@ -46,8 +46,8 @@ 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) 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 @@ -63,7 +63,7 @@ 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) = 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 @@ -47,8 +47,9 @@ 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 @@ -52,7 +52,7 @@ 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/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 @@ -56,8 +56,8 @@ 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 + 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 :: Type -> [(Name, Name, Type)] -> ExpQ 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 @@ -62,7 +62,7 @@ genShowFClause fArg (constr, args, ty) = do let n = length args varNs <- newNames n "x" - let pat = ConP constr $ map VarP varNs + let pat = ConP constr [] $ map VarP varNs allVars = zipWith (filterFarg (getBinaryFArg fArg ty)) args varNs shows = listE $ map mkShow allVars conName = nameBase constr 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 @@ -64,6 +64,6 @@ ftype = foldl appT (conT tname) (map varT targs') 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,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} 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 @@ -40,6 +40,7 @@ ) where import Data.Functor.Compose +import Data.Kind -- | The identity Functor. newtype I a = I {unI :: a} deriving (Functor, Foldable, Traversable) @@ -102,4 +103,4 @@ 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/Mapping.hs b/src/Data/Comp/Multi/Mapping.hs --- a/src/Data/Comp/Multi/Mapping.hs +++ b/src/Data/Comp/Multi/Mapping.hs @@ -30,6 +30,8 @@ import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable +import Data.Kind + import Control.Monad.State import Data.IntMap (IntMap) @@ -57,7 +59,7 @@ infixr 0 & -class Mapping m (k :: * -> *) | m -> k where +class Mapping m (k :: Type -> Type) | m -> k where -- | left-biased union of two mappings. (&) :: m v -> m v -> m v @@ -76,7 +78,7 @@ findWithDefault :: a -> k i -> m a -> a -newtype NumMap (k :: * -> *) v = NumMap (IntMap v) deriving Functor +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 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 @@ -37,6 +37,8 @@ import Control.Monad +import Data.Kind + import Data.Comp.Multi.HFoldable import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable @@ -48,8 +50,8 @@ -- |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. -} @@ -88,15 +90,15 @@ infixl 5 :<: infixl 5 :=: -type family Elem (f :: (* -> *) -> * -> *) - (g :: (* -> *) -> * -> *) :: Emb where +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 -class Subsume (e :: Emb) (f :: (* -> *) -> * -> *) - (g :: (* -> *) -> * -> *) where +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) @@ -158,12 +160,12 @@ -- 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 @@ -184,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/Projection.hs b/src/Data/Comp/Multi/Projection.hs --- a/src/Data/Comp/Multi/Projection.hs +++ b/src/Data/Comp/Multi/Projection.hs @@ -31,15 +31,17 @@ import Data.Comp.SubsumeCommon import Data.Comp.Multi.Ops hiding (Elem) -type family Elem (f :: * -> *) - (g :: * -> *) :: Emb where +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 :: * -> *) - (q :: * -> *) where +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 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 @@ -36,13 +36,13 @@ import Data.Comp.Multi.HFunctor import Data.Comp.Multi.HTraversable - +import Data.Kind import Control.Monad 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 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 @@ -47,8 +47,9 @@ 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) @@ -71,7 +72,7 @@ {-| 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 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 @@ -29,6 +29,7 @@ import Data.Foldable import Data.Traversable +import Data.Kind import Control.Applicative import Control.Monad hiding (mapM, sequence) @@ -92,13 +93,13 @@ infixl 5 :<: infixl 5 :=: -type family Elem (f :: * -> *) (g :: * -> *) :: Emb where +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 Subsume (e :: Emb) (f :: * -> *) (g :: * -> *) where +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) diff --git a/src/Data/Comp/Projection.hs b/src/Data/Comp/Projection.hs --- a/src/Data/Comp/Projection.hs +++ b/src/Data/Comp/Projection.hs @@ -30,15 +30,17 @@ import Data.Comp.SubsumeCommon -type family Elem (f :: *) - (g :: *) :: Emb where +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 :: *) - (q :: *) where +class Proj (e :: Emb) (p :: Type) + (q :: Type) where pr' :: Proxy e -> q -> p instance Proj (Found Here) f f where 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 @@ -35,6 +35,7 @@ import Control.Applicative hiding (Const) import Control.Monad hiding (mapM, sequence) +import Data.Kind import Data.Foldable import Data.Traversable import Unsafe.Coerce @@ -58,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 @@ -104,7 +105,6 @@ (<*>) = ap instance (Functor f) => Monad (Context f) where - return = Hole m >>= f = run m where run (Hole v) = f v run (Term t) = Term (fmap run t) 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 @@ -54,11 +54,6 @@ import Control.Monad hiding (mapM, sequence) import Data.Traversable --- 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 Prelude hiding (foldl, foldl1, foldr, foldr1, mapM, sequence) 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 @@ -20,6 +20,7 @@ import Data.Comp.Term import Data.Comp.Variables +import Control.Monad import Control.Monad.Except import Control.Monad.State