compdata-param 0.9.1 → 0.9.2
raw patch · 20 files changed
+64/−52 lines, 20 filesdep ~compdata
Dependency ranges changed: compdata
Files
- compdata-param.cabal +17/−4
- examples/Examples/Graph.hs +1/−2
- examples/Examples/Lambda.hs +1/−1
- examples/Examples/Multi/FOL.hs +4/−4
- examples/Examples/Multi/Lambda.hs +4/−4
- examples/Examples/Names.hs +7/−7
- examples/Examples/Thunk.hs +2/−2
- src/Data/Comp/Param/Derive/Injections.hs +4/−4
- src/Data/Comp/Param/Derive/Projections.hs +4/−4
- src/Data/Comp/Param/Derive/SmartConstructors.hs +1/−1
- src/Data/Comp/Param/Desugar.hs +2/−2
- src/Data/Comp/Param/Equality.hs +2/−2
- src/Data/Comp/Param/FreshM.hs +0/−1
- src/Data/Comp/Param/Multi/Derive/Injections.hs +4/−4
- src/Data/Comp/Param/Multi/Derive/Projections.hs +4/−4
- src/Data/Comp/Param/Multi/Derive/SmartConstructors.hs +4/−2
- src/Data/Comp/Param/Multi/Desugar.hs +2/−2
- src/Data/Comp/Param/Multi/FreshM.hs +0/−1
- src/Data/Comp/Param/Multi/HDitraversable.hs +1/−1
- src/Data/Comp/Param/Ordering.hs +0/−0
compdata-param.cabal view
@@ -1,5 +1,5 @@ Name: compdata-param-Version: 0.9.1+Version: 0.9.2 Synopsis: Parametric Compositional Data Types Description: @@ -23,7 +23,7 @@ License: BSD3 License-file: LICENSE Author: Patrick Bahr, Tom Hvitved-Maintainer: paba@di.ku.dk+Maintainer: paba@itu.dk Build-Type: Simple Cabal-Version: >=1.9.2 bug-reports: https://github.com/pa-ba/compdata-param/issues@@ -90,7 +90,8 @@ Data.Comp.Param.Multi.Derive.Injections Data.Comp.Param.Multi.Derive.Projections - Build-Depends: base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.10.1 && < 0.11+ Build-Depends: base >= 4.7, base < 5, template-haskell, mtl, transformers,+ compdata >= 0.12 && < 0.13 hs-source-dirs: src ghc-options: -W @@ -98,8 +99,20 @@ Test-Suite test Type: exitcode-stdio-1.0 Main-is: Tests.hs+ Other-Modules: Data.Comp.Examples.MultiParam+ Data.Comp.Examples.Param+ Data.Comp.Examples_Test+ Examples.Graph+ Examples.Multi.FOL+ Examples.Names++ Examples.Multi.Lambda+ Examples.Thunk+ Examples.Lambda+ hs-source-dirs: testsuite/tests examples- Build-Depends: base >= 4.7, base < 5, template-haskell, mtl, transformers, compdata >= 0.10.1 && < 0.11, HUnit,+ Build-Depends: base >= 4.7, base < 5, template-haskell, mtl, transformers,+ compdata >= 0.12 && < 0.13, HUnit, test-framework, test-framework-hunit, containers, compdata-param source-repository head
examples/Examples/Graph.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE TypeOperators, MultiParamTypeClasses, TemplateHaskell,- FlexibleInstances, FlexibleContexts, UndecidableInstances,- OverlappingInstances #-}+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : Examples.Param.Graph
examples/Examples/Lambda.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances,- OverlappingInstances, Rank2Types, GADTs #-}+ Rank2Types, GADTs #-} -------------------------------------------------------------------------------- -- | -- Module : Examples.Param.Lambda
examples/Examples/Multi/FOL.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs, KindSignatures,- OverlappingInstances, TypeSynonymInstances, EmptyDataDecls #-}+ TypeSynonymInstances, EmptyDataDecls #-} -------------------------------------------------------------------------------- -- | -- Module : Examples.MultiParam.FOL@@ -153,7 +153,7 @@ elimImp :: Term Input :-> Term Stage1 elimImp (Term t) = Term (appHom elimImpHom t) -instance (HDifunctor f, f :<: Stage1) => ElimImp f where+instance {-# OVERLAPPABLE #-} (HDifunctor f, f :<: Stage1) => ElimImp f where elimImpHom = simpCxt . inj instance ElimImp Impl where@@ -212,7 +212,7 @@ pushNotInwards :: Term Stage1 :-> Term Stage2 pushNotInwards t = Term (cata pushNotAlg t) -instance (HDifunctor f, f :<: Stage2) => PushNot f where+instance {-# OVERLAPPABLE #-} (HDifunctor f, f :<: Stage2) => PushNot f where pushNotAlg = inject . hdimap MP.Var id -- default instance PushNot Not where@@ -237,7 +237,7 @@ (genSupply (2 * n + 1)) splitUniqueSupply :: UniqueSupply -> (UniqueSupply, UniqueSupply)-splitUniqueSupply (UniqueSupply _ l r) = (l,r)+splitUniqueSupply (UniqueSupply _ l r) = (l,r) getUnique :: UniqueSupply -> (Unique, UniqueSupply) getUnique (UniqueSupply n l _) = (n,l)
examples/Examples/Multi/Lambda.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, UndecidableInstances,- OverlappingInstances, Rank2Types, GADTs, KindSignatures,+ Rank2Types, GADTs, KindSignatures, ScopedTypeVariables, TypeFamilies #-} -------------------------------------------------------------------------------- -- |@@ -22,7 +22,7 @@ import Data.Comp.Param.Multi.Equality () import Data.Comp.Param.Multi.Derive import Control.Monad (liftM2)-import Control.Monad.Error (MonadError, throwError)+import Control.Monad.Except (MonadError, throwError) data Lam :: (* -> *) -> (* -> *) -> * -> * where Lam :: (a i -> b j) -> Lam a b (i -> j)@@ -36,7 +36,7 @@ Err :: Err a b i type Sig = Lam :+: App :+: Const :+: Plus :+: Err -$(derive [smartConstructors, makeHDifunctor, makeShowHD, makeEqHD]+$(derive [smartConstructors, makeHDifunctor, makeEqHD] [''Lam, ''App, ''Const, ''Plus, ''Err]) -- * Tagless interpretation@@ -90,7 +90,7 @@ instance Monad m => EvalM m Plus where evalMAlg (Plus (M mx) (M my)) = liftM2 (+) mx my -instance MonadError String m => EvalM m Err where+instance (MonadError String m, Monad m) => EvalM m Err where evalMAlg Err = throwError "error" -- 'throwError' rather than 'error' e :: Term Sig Int
examples/Examples/Names.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,- FlexibleInstances, FlexibleContexts, UndecidableInstances,- OverlappingInstances #-}+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : Examples.Param.Names@@ -68,7 +67,7 @@ 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+instance {-# OVERLAPPABLE #-} (Ditraversable f, f :<: g) => N2PTrans f g where n2pAlg = liftM inject . disequence . dimap (return . P.Var) id -- default instance N2PTrans NVar g where@@ -99,13 +98,14 @@ 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+instance {-# OVERLAPPABLE #-} (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)-+ p2nAlg (Lam f) = do r <- ask+ case r of+ n:names -> return $ iNLam n (runReader (f (return $ iNVar n)) names)+ _ -> error "name expected" ep' :: Term SigP ep' = Term $ iLam $ \a -> iLam (\b -> (iLam $ \_ -> b)) `iApp` a
examples/Examples/Thunk.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,- FlexibleInstances, FlexibleContexts, UndecidableInstances, OverlappingInstances #-}+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : Examples.Param.Thunk@@ -57,7 +57,7 @@ -- instance (Ditraversable f Maybe Any, f :<: v) => EvalT f v where -- evalAlgT = strict' -instance (Difunctor f, f :<: v) => EvalT f v where+instance {-# OVERLAPPABLE #-} (Difunctor f, f :<: v) => EvalT f v where evalAlgT = inject'
src/Data/Comp/Param/Derive/Injections.hs view
@@ -36,7 +36,7 @@ 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 cxt = map (\f -> (conT ''(:<:) `appT` varT f) `appT` 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)@@ -59,7 +59,7 @@ 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 cxt = map (\f -> conT ''(:<:) `appT` varT f `appT` 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@@ -77,10 +77,10 @@ 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 cxt = map (\f -> conT ''(:<:) `appT` varT f `appT` varT gvar) fvars let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) (map varT fvars)- let cxt' = classP ''Difunctor [tp]+ let cxt' = conT ''Difunctor `appT` tp let tp' = conT ''CxtFun `appT` tp `appT` varT gvar forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp' genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
src/Data/Comp/Param/Derive/Projections.hs view
@@ -37,7 +37,7 @@ 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 cxt = map (\g -> conT ''(:<:) `appT` varT g `appT` 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`@@ -68,7 +68,7 @@ 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 cxt = map (\g -> conT ''(:<:) `appT` varT g `appT` 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@@ -91,10 +91,10 @@ 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 cxt = map (\g -> conT ''(:<:) `appT` varT g `appT` varT fvar) gvars let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) (map varT gvars)- let cxt' = classP ''Ditraversable [tp]+ let cxt' = conT ''Ditraversable `appT` 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'
src/Data/Comp/Param/Derive/SmartConstructors.hs view
@@ -55,7 +55,7 @@ a = varT avar b = varT bvar 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, b] typeSig = forallT (map PlainTV vars) (sequence [constr]) typ sigD sname typeSig
src/Data/Comp/Param/Desugar.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,- UndecidableInstances, OverlappingInstances, Rank2Types, TypeOperators #-}+ UndecidableInstances, Rank2Types, TypeOperators #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Param.Desugar@@ -41,5 +41,5 @@ desugarA (Term t) = Term (appHom (propAnn desugHom) t) -- |Default desugaring instance.-instance (Difunctor f, Difunctor g, f :<: g) => Desugar f g where+instance {-# OVERLAPPABLE #-} (Difunctor f, Difunctor g, f :<: g) => Desugar f g where desugHom = simpCxt . inj
src/Data/Comp/Param/Equality.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,- UndecidableInstances, IncoherentInstances, GADTs #-}+ UndecidableInstances, GADTs #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Param.Equality@@ -36,7 +36,7 @@ | length l1 /= length l2 = return False | otherwise = liftM or $ mapM (uncurry peq) $ zip l1 l2 -instance Eq a => PEq a where+instance {-# OVERLAPPABLE #-} Eq a => PEq a where peq x y = return $ x == y {-| Signature equality. An instance @EqD f@ gives rise to an instance
src/Data/Comp/Param/FreshM.hs view
@@ -21,7 +21,6 @@ ) where import Control.Monad.Reader-import Control.Applicative -- |Monad for generating fresh (abstract) names. newtype FreshM a = FreshM{unFreshM :: Reader Int a}
src/Data/Comp/Param/Multi/Derive/Injections.hs view
@@ -37,7 +37,7 @@ 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 cxt = map (\f -> (conT ''(:<:) `appT` varT f) `appT` 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`@@ -62,7 +62,7 @@ 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 cxt = map (\f -> (conT ''(:<:) `appT` varT f) `appT` 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@@ -82,10 +82,10 @@ 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 cxt = map (\f -> (conT ''(:<:) `appT` varT f) `appT` varT gvar) fvars let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a) (map varT fvars)- let cxt' = classP ''HDifunctor [tp]+ let cxt' = conT ''HDifunctor `appT` tp let tp' = conT ''CxtFun `appT` tp `appT` varT gvar forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp' genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
src/Data/Comp/Param/Multi/Derive/Projections.hs view
@@ -38,7 +38,7 @@ 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 cxt = map (\g -> (conT ''(:<:) `appT` varT g) `appT` 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`@@ -73,7 +73,7 @@ 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 cxt = map (\g -> (conT ''(:<:) `appT` varT g) `appT` 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@@ -98,10 +98,10 @@ where genSig gvars = do let fvar = mkName "f" let ivar = mkName "i"- let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars+ let cxt = map (\g -> (conT ''(:<:) `appT` varT g) `appT` varT fvar) gvars let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a) (map varT gvars)- let cxt' = classP ''HDitraversable [tp]+ let cxt' = conT ''HDitraversable `appT` 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'
src/Data/Comp/Param/Multi/Derive/SmartConstructors.hs view
@@ -55,6 +55,8 @@ sig = genSig targs tname sname args miTp function = [funD sname [clause pats (normalB [|inject (hdimap Var id $val)|]) []]] sequence $ sig ++ function+ isVar (VarT n) = [n]+ isVar _ = [] genSig targs tname sname 0 miTp = (:[]) $ do hvar <- newName "h" fvar <- newName "f"@@ -62,14 +64,14 @@ bvar <- newName "b" ivar <- newName "i" let targs' = init $ init $ init targs- vars = hvar:fvar:avar:bvar:maybe [ivar] (const []) miTp++targs'+ vars = hvar:fvar:avar:bvar:maybe [ivar] isVar 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]+ constr = (conT ''(:<:) `appT` ftype) `appT` 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
src/Data/Comp/Param/Multi/Desugar.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,- UndecidableInstances, OverlappingInstances, TypeOperators, Rank2Types #-}+ UndecidableInstances, TypeOperators, Rank2Types #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Param.Multi.Desugar@@ -40,5 +40,5 @@ desugarA (Term t) = Term (appHom (propAnn desugHom) t) -- |Default desugaring instance.-instance (HDifunctor f, HDifunctor g, f :<: g) => Desugar f g where+instance {-# OVERLAPPABLE #-} (HDifunctor f, HDifunctor g, f :<: g) => Desugar f g where desugHom = simpCxt . inj
src/Data/Comp/Param/Multi/FreshM.hs view
@@ -22,7 +22,6 @@ ) where import Control.Monad.Reader-import Control.Applicative -- |Monad for generating fresh (abstract) names. newtype FreshM a = FreshM{unFreshM :: Reader Int a}
src/Data/Comp/Param/Multi/HDitraversable.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE Rank2Types, FlexibleInstances, MultiParamTypeClasses,- FlexibleContexts, OverlappingInstances, TypeOperators, GADTs #-}+ FlexibleContexts, TypeOperators, GADTs #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Param.Multi.HDitraversable
src/Data/Comp/Param/Ordering.hs view