compdata 0.2 → 0.3
raw patch · 149 files changed
+10521/−2072 lines, 149 filesdep +transformersPVP ok
version bump matches the API change (PVP)
Dependencies added: transformers
API changes (from Hackage documentation)
- Data.Comp.Algebra: termHomM' :: (Traversable f, Functor g, Monad m) => TermHomM' m f g -> CxtFunM m f g
- Data.Comp.Algebra: type SigFunM' m f g = forall a. f (m a) -> m (g a)
- Data.Comp.Algebra: type TermHomM' m f g = SigFunM' m f (Context g)
- Data.Comp.Automata: DUTA :: DUTATrans f q -> (q -> Bool) -> DUTA f q
- Data.Comp.Automata: DUTT :: DUTTTrans f g q -> (q -> Bool) -> DUTT f g q
- Data.Comp.Automata: NUTA :: AlgM [] f q -> (q -> Bool) -> NUTA f q
- Data.Comp.Automata: NUTT :: NUTTTrans f g q -> (q -> Bool) -> NUTT f g q
- Data.Comp.Automata: data DUTA f q
- Data.Comp.Automata: data DUTT f g q
- Data.Comp.Automata: data NUTA f q
- Data.Comp.Automata: data NUTT f g q
- Data.Comp.Automata: determNUTA :: Traversable f => NUTA f q -> DUTA f [q]
- Data.Comp.Automata: duta :: Functor f => DUTA f q -> Term f -> Bool
- Data.Comp.Automata: dutaAccept :: DUTA f q -> q -> Bool
- Data.Comp.Automata: dutaTrans :: DUTA f q -> DUTATrans f q
- Data.Comp.Automata: dutt :: (Functor f, Functor g) => DUTT f g q -> Term f -> Maybe (Term g)
- Data.Comp.Automata: duttAccept :: DUTT f g q -> q -> Bool
- Data.Comp.Automata: duttTrans :: DUTT f g q -> DUTTTrans f g q
- Data.Comp.Automata: duttTransAlg :: (Functor f, Functor g) => DUTTTrans f g q -> Alg f (q, Term g)
- Data.Comp.Automata: nuta :: Traversable f => NUTA f q -> Term f -> Bool
- Data.Comp.Automata: nutaAccept :: NUTA f q -> q -> Bool
- Data.Comp.Automata: nutaTrans :: NUTA f q -> AlgM [] f q
- Data.Comp.Automata: nutt :: (Traversable f, Functor g) => NUTT f g q -> Term f -> [Term g]
- Data.Comp.Automata: nuttAccept :: NUTT f g q -> q -> Bool
- Data.Comp.Automata: nuttTrans :: NUTT f g q -> NUTTTrans f g q
- Data.Comp.Automata: nuttTransAlg :: (Functor f, Functor g) => NUTTTrans f g q -> AlgM [] f (q, Term g)
- Data.Comp.Automata: runDUTATrans :: Functor f => DUTATrans f q -> Term f -> q
- Data.Comp.Automata: runDUTTTrans :: (Functor f, Functor g) => DUTTTrans f g q -> Term f -> (q, Term g)
- Data.Comp.Automata: runNUTATrans :: Traversable f => NUTATrans f q -> Term f -> [q]
- Data.Comp.Automata: runNUTTTrans :: (Traversable f, Functor g) => NUTTTrans f g q -> Term f -> [(q, Term g)]
- Data.Comp.Automata: type DUTATrans f q = Alg f q
- Data.Comp.Automata: type DUTTTrans f g q = forall a. f (q, a) -> (q, Cxt Hole g a)
- Data.Comp.Automata: type NUTATrans f q = AlgM [] f q
- Data.Comp.Automata: type NUTTTrans f g q = forall a. f (q, a) -> [(q, Cxt Hole g a)]
- Data.Comp.Derive: class HEqF f
- Data.Comp.Derive: class HFunctor h => HFoldable h
- Data.Comp.Derive: class HFunctor h
- Data.Comp.Derive: class HShowF f
- Data.Comp.Derive: class HFoldable t => HTraversable t
- Data.Comp.Derive: class KEq f
- Data.Comp.Derive: class KShow a
- Data.Comp.Derive: heqF :: (HEqF f, KEq g) => f g i -> f g j -> Bool
- Data.Comp.Derive: hshowF :: HShowF f => Alg f (K String)
- Data.Comp.Derive: hshowF' :: HShowF f => f (K String) :=> String
- Data.Comp.Derive: instanceArbitrary :: Name -> Q [Dec]
- Data.Comp.Derive: instanceArbitraryF :: Name -> Q [Dec]
- Data.Comp.Derive: instanceEqF :: Name -> Q [Dec]
- Data.Comp.Derive: instanceFoldable :: Name -> Q [Dec]
- Data.Comp.Derive: instanceFunctor :: Name -> Q [Dec]
- Data.Comp.Derive: instanceHEqF :: Name -> Q [Dec]
- Data.Comp.Derive: instanceHFoldable :: Name -> Q [Dec]
- Data.Comp.Derive: instanceHFunctor :: Name -> Q [Dec]
- Data.Comp.Derive: instanceHShowF :: Name -> Q [Dec]
- Data.Comp.Derive: instanceHTraversable :: Name -> Q [Dec]
- Data.Comp.Derive: instanceNFData :: Name -> Q [Dec]
- Data.Comp.Derive: instanceNFDataF :: Name -> Q [Dec]
- Data.Comp.Derive: instanceOrdF :: Name -> Q [Dec]
- Data.Comp.Derive: instanceShowF :: Name -> Q [Dec]
- Data.Comp.Derive: instanceTraversable :: Name -> Q [Dec]
- Data.Comp.Derive: keq :: KEq f => f i -> f j -> Bool
- Data.Comp.Derive: kshow :: KShow a => a i -> K String i
- Data.Comp.Derive: smartHConstructors :: Name -> Q [Dec]
- Data.Comp.Multi.Ops: class DistProd s :: ((* -> *) -> * -> *) p s' | s' -> s, s' -> p
- Data.Comp.Multi.Ops: class RemoveP s :: ((* -> *) -> * -> *) s' | s -> s'
- Data.Comp.Multi.Ops: injectP :: DistProd s p s' => p -> s a :-> s' a
- Data.Comp.Multi.Ops: instance [incoherent] DistProd f p (f :&: p)
- Data.Comp.Multi.Ops: instance [incoherent] DistProd s p s' => DistProd (f :+: s) p ((f :&: p) :+: s')
- Data.Comp.Multi.Ops: instance [incoherent] RemoveP (f :&: p) f
- Data.Comp.Multi.Ops: instance [incoherent] RemoveP s s' => RemoveP ((f :&: p) :+: s) (f :+: s')
- Data.Comp.Multi.Ops: projectP :: DistProd s p s' => s' a :-> (s a :&: p)
- Data.Comp.Multi.Ops: removeP :: RemoveP s s' => s a :-> s' a
- Data.Comp.Multi.Product: (:&:) :: f g e -> a -> :&: f a e
- Data.Comp.Multi.Product: class DistProd s :: ((* -> *) -> * -> *) p s' | s' -> s, s' -> p
- Data.Comp.Multi.Product: class RemoveP s :: ((* -> *) -> * -> *) s' | s -> s'
- Data.Comp.Multi.Product: constP :: (DistProd f p g, HFunctor f, HFunctor g) => p -> Cxt h f a :-> Cxt h g a
- Data.Comp.Multi.Product: data (:&:) f a g :: (* -> *) e
- Data.Comp.Multi.Product: injectP :: DistProd s p s' => p -> s a :-> s' a
- Data.Comp.Multi.Product: liftP :: RemoveP s s' => (s' a :-> t) -> s a :-> t
- Data.Comp.Multi.Product: liftP' :: (DistProd s' p s, HFunctor s, HFunctor s') => (s' a :-> Cxt h s' a) -> s a :-> Cxt h s a
- Data.Comp.Multi.Product: productTermHom :: (DistProd f p f', DistProd g p g', HFunctor g, HFunctor g') => TermHom f g -> TermHom f' g'
- Data.Comp.Multi.Product: project' :: (:<: s f, RemoveP s s') => Cxt h f a i -> Maybe (s' (Cxt h f a) i)
- Data.Comp.Multi.Product: projectP :: DistProd s p s' => s' a :-> (s a :&: p)
- Data.Comp.Multi.Product: removeP :: RemoveP s s' => s a :-> s' a
- Data.Comp.Multi.Product: stripP :: (HFunctor f, RemoveP g f, HFunctor g) => Cxt h g a :-> Cxt h f a
- Data.Comp.Multi.Sum: Inl :: (f h e) -> :+: f g e
- Data.Comp.Multi.Sum: Inr :: (g h e) -> :+: f g e
- Data.Comp.Multi.Variables: instance [overlap ok] (HasVars f v, HasVars g v) => HasVars (f :+: g) v
- Data.Comp.Ops: class DistProd s p s' | s' -> s, s' -> p
- Data.Comp.Ops: class RemoveP s s' | s -> s'
- Data.Comp.Ops: injectP :: DistProd s p s' => p -> s a -> s' a
- Data.Comp.Ops: instance [incoherent] DistProd f p (f :&: p)
- Data.Comp.Ops: instance [incoherent] DistProd s p s' => DistProd (f :+: s) p ((f :&: p) :+: s')
- Data.Comp.Ops: instance [incoherent] RemoveP (f :&: p) f
- Data.Comp.Ops: instance [incoherent] RemoveP s s' => RemoveP ((f :&: p) :+: s) (f :+: s')
- Data.Comp.Ops: projectP :: DistProd s p s' => s' a -> (s a, p)
- Data.Comp.Ops: removeP :: RemoveP s s' => s a -> s' a
- Data.Comp.Product: (:&:) :: f e -> a -> :&: f a e
- Data.Comp.Product: (:*:) :: f a -> g a -> :*: f g a
- Data.Comp.Product: class DistProd s p s' | s' -> s, s' -> p
- Data.Comp.Product: class RemoveP s s' | s -> s'
- Data.Comp.Product: constP :: (DistProd f p g, Functor f, Functor g) => p -> Cxt h f a -> Cxt h g a
- Data.Comp.Product: data (:*:) f g a
- Data.Comp.Product: injectP :: DistProd s p s' => p -> s a -> s' a
- Data.Comp.Product: liftP :: RemoveP s s' => (s' a -> t) -> s a -> t
- Data.Comp.Product: liftP' :: (DistProd s' p s, Functor s, Functor s') => (s' a -> Cxt h s' a) -> s a -> Cxt h s a
- Data.Comp.Product: productTermHom :: (DistProd f p f', DistProd g p g', Functor g, Functor g') => TermHom f g -> TermHom f' g'
- Data.Comp.Product: project' :: (:<: s f, RemoveP s s') => Cxt h f a -> Maybe (s' (Cxt h f a))
- Data.Comp.Product: projectP :: DistProd s p s' => s' a -> (s a, p)
- Data.Comp.Product: removeP :: RemoveP s s' => s a -> s' a
- Data.Comp.Product: stripP :: (Functor f, RemoveP g f, Functor g) => Cxt h g a -> Cxt h f a
- Data.Comp.Sum: Inl :: (f e) -> :+: f g e
- Data.Comp.Sum: Inr :: (g e) -> :+: f g e
- Data.Comp.Sum: deepProject' :: (Traversable g, :<: g f) => Cxt h f a -> Maybe (Cxt h g a)
- Data.Comp.Sum: deepProject2' :: (Traversable g1, Traversable g2, :<: g1 f, :<: g2 f) => Cxt h f a -> Maybe (Cxt h (g1 :+: g2) a)
- Data.Comp.Sum: deepProject3' :: (Traversable g1, Traversable g2, Traversable g3, :<: g1 f, :<: g2 f, :<: g3 f) => Cxt h f a -> Maybe (Cxt h (g1 :+: (g2 :+: g3)) a)
- Data.Comp.Variables: instance [overlap ok] (HasVars f v, HasVars g v) => HasVars (f :+: g) v
+ Data.Comp.Algebra: appSigFun' :: Functor g => SigFun f g -> CxtFun f g
+ Data.Comp.Algebra: appSigFunMD :: (Traversable f, Functor g, Monad m) => SigFunMD m f g -> CxtFunM m f g
+ Data.Comp.Algebra: appTermHom' :: Functor g => TermHom f g -> CxtFun f g
+ Data.Comp.Algebra: appTermHomM' :: (Traversable g, Monad m) => TermHomM m f g -> CxtFunM m f g
+ Data.Comp.Algebra: compAlgSigFun :: Alg g a -> SigFun f g -> Alg f a
+ Data.Comp.Algebra: compAlgSigFunM :: Monad m => AlgM m g a -> SigFunM m f g -> AlgM m f a
+ Data.Comp.Algebra: compSigFunTermHom :: Functor g => SigFun g h -> TermHom f g -> TermHom f h
+ Data.Comp.Algebra: compSigFunTermHomM :: (Traversable g, Functor h, Monad m) => SigFunM m g h -> TermHomM m f g -> TermHomM m f h
+ Data.Comp.Algebra: compTermHomSigFun :: TermHom g h -> SigFun f g -> TermHom f h
+ Data.Comp.Algebra: compTermHomSigFunM :: Monad m => TermHomM m g h -> SigFunM m f g -> TermHomM m f h
+ Data.Comp.Algebra: termHomMD :: (Traversable f, Functor g, Monad m) => TermHomMD m f g -> CxtFunM m f g
+ Data.Comp.Algebra: type SigFunMD m f g = forall a. f (m a) -> m (g a)
+ Data.Comp.Algebra: type TermHomMD m f g = SigFunMD m f (Context g)
+ Data.Comp.Annotation: (:&:) :: f e -> a -> :&: f a e
+ Data.Comp.Annotation: (:*:) :: f a -> g a -> :*: f g a
+ Data.Comp.Annotation: ann :: (DistAnn f p g, Functor f) => p -> CxtFun f g
+ Data.Comp.Annotation: class DistAnn s p s' | s' -> s, s' -> p
+ Data.Comp.Annotation: class RemA s s' | s -> s'
+ Data.Comp.Annotation: data (:*:) f g a
+ Data.Comp.Annotation: injectA :: DistAnn s p s' => p -> s a -> s' a
+ Data.Comp.Annotation: liftA :: RemA s s' => (s' a -> t) -> s a -> t
+ Data.Comp.Annotation: liftA' :: (DistAnn s' p s, Functor s') => (s' a -> Cxt h s' a) -> s a -> Cxt h s a
+ Data.Comp.Annotation: project' :: (:<: s f, RemA s s') => Cxt h f a -> Maybe (s' (Cxt h f a))
+ Data.Comp.Annotation: projectA :: DistAnn s p s' => s' a -> (s a, p)
+ Data.Comp.Annotation: propAnn :: (DistAnn f p f', DistAnn g p g', Functor g) => TermHom f g -> TermHom f' g'
+ Data.Comp.Annotation: propAnnM :: (DistAnn f p f', DistAnn g p g', Functor g, Monad m) => TermHomM m f g -> TermHomM m f' g'
+ Data.Comp.Annotation: remA :: RemA s s' => s a -> s' a
+ Data.Comp.Annotation: stripA :: (RemA g f, Functor g) => CxtFun g f
+ Data.Comp.Derive: caseF :: (f a -> b) -> (g a -> b) -> (f :+: g) a -> b
+ Data.Comp.Derive: liftSum :: Name -> Q [Dec]
+ Data.Comp.Derive: makeArbitrary :: Name -> Q [Dec]
+ Data.Comp.Derive: makeArbitraryF :: Name -> Q [Dec]
+ Data.Comp.Derive: makeEqF :: Name -> Q [Dec]
+ Data.Comp.Derive: makeFoldable :: Name -> Q [Dec]
+ Data.Comp.Derive: makeFunctor :: Name -> Q [Dec]
+ Data.Comp.Derive: makeNFData :: Name -> Q [Dec]
+ Data.Comp.Derive: makeNFDataF :: Name -> Q [Dec]
+ Data.Comp.Derive: makeOrdF :: Name -> Q [Dec]
+ Data.Comp.Derive: makeShowF :: Name -> Q [Dec]
+ Data.Comp.Derive: makeTraversable :: Name -> Q [Dec]
+ Data.Comp.Derive: smartAConstructors :: Name -> Q [Dec]
+ Data.Comp.Desugar: class (Functor f, Functor g) => Desugar f g
+ Data.Comp.Desugar: desugHom :: Desugar f g => TermHom f g
+ Data.Comp.Desugar: desugHom' :: Desugar f g => Alg f (Context g a)
+ Data.Comp.Desugar: desugar :: Desugar f g => Term f -> Term g
+ Data.Comp.Desugar: desugarA :: (Functor f', Functor g', DistAnn f p f', DistAnn g p g', Desugar f g) => Term f' -> Term g'
+ Data.Comp.Desugar: instance [overlap ok] (Desugar f g[a2ams], Desugar g g[a2ams]) => Desugar (f :+: g) g[a2ams]
+ Data.Comp.Desugar: instance [overlap ok] (Functor f, Functor g, f :<: g) => Desugar f g
+ Data.Comp.Multi.Algebra: appSigFun' :: HFunctor g => SigFun f g -> CxtFun f g
+ Data.Comp.Multi.Algebra: appSigFunM' :: (HTraversable g, Monad m) => SigFunM m f g -> CxtFunM m f g
+ Data.Comp.Multi.Algebra: appTermHom' :: HFunctor g => TermHom f g -> CxtFun f g
+ Data.Comp.Multi.Algebra: appTermHomM' :: (HTraversable g, Monad m) => TermHomM m f g -> CxtFunM m f g
+ Data.Comp.Multi.Algebra: termHom' :: (HFunctor f, HFunctor g, Monad m) => SigFunM m f g -> TermHomM m f g
+ Data.Comp.Multi.Annotation: (:&:) :: f g e -> a -> :&: f a e
+ Data.Comp.Multi.Annotation: ann :: (DistAnn f p g, HFunctor f) => p -> CxtFun f g
+ Data.Comp.Multi.Annotation: class DistAnn s :: ((* -> *) -> * -> *) p s' | s' -> s, s' -> p
+ Data.Comp.Multi.Annotation: class RemA s :: ((* -> *) -> * -> *) s' | s -> s'
+ Data.Comp.Multi.Annotation: data (:&:) f a g :: (* -> *) e
+ Data.Comp.Multi.Annotation: injectA :: DistAnn s p s' => p -> s a :-> s' a
+ Data.Comp.Multi.Annotation: liftA :: RemA s s' => (s' a :-> t) -> s a :-> t
+ Data.Comp.Multi.Annotation: liftA' :: (DistAnn s' p s, HFunctor s') => (s' a :-> Cxt h s' a) -> s a :-> Cxt h s a
+ Data.Comp.Multi.Annotation: project' :: (:<: s f, RemA s s') => Cxt h f a i -> Maybe (s' (Cxt h f a) i)
+ Data.Comp.Multi.Annotation: projectA :: DistAnn s p s' => s' a :-> (s a :&: p)
+ Data.Comp.Multi.Annotation: propAnn :: (DistAnn f p f', DistAnn g p g', HFunctor g) => TermHom f g -> TermHom f' g'
+ Data.Comp.Multi.Annotation: remA :: RemA s s' => s a :-> s' a
+ Data.Comp.Multi.Annotation: stripA :: (RemA g f, HFunctor g) => CxtFun g f
+ Data.Comp.Multi.Derive: caseH :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c
+ Data.Comp.Multi.Derive: class HEqF f
+ Data.Comp.Multi.Derive: class HFunctor h => HFoldable h
+ Data.Comp.Multi.Derive: class HFunctor h
+ Data.Comp.Multi.Derive: class HShowF f
+ Data.Comp.Multi.Derive: class HFoldable t => HTraversable t
+ Data.Comp.Multi.Derive: class KEq f
+ Data.Comp.Multi.Derive: class KShow a
+ Data.Comp.Multi.Derive: derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]
+ Data.Comp.Multi.Derive: heqF :: (HEqF f, KEq g) => f g i -> f g j -> Bool
+ Data.Comp.Multi.Derive: hshowF :: HShowF f => Alg f (K String)
+ Data.Comp.Multi.Derive: hshowF' :: HShowF f => f (K String) :=> String
+ Data.Comp.Multi.Derive: keq :: KEq f => f i -> f j -> Bool
+ Data.Comp.Multi.Derive: kshow :: KShow a => a i -> K String i
+ Data.Comp.Multi.Derive: liftSum :: Name -> Q [Dec]
+ Data.Comp.Multi.Derive: makeHEqF :: Name -> Q [Dec]
+ Data.Comp.Multi.Derive: makeHFoldable :: Name -> Q [Dec]
+ Data.Comp.Multi.Derive: makeHFunctor :: Name -> Q [Dec]
+ Data.Comp.Multi.Derive: makeHShowF :: Name -> Q [Dec]
+ Data.Comp.Multi.Derive: makeHTraversable :: Name -> Q [Dec]
+ Data.Comp.Multi.Derive: smartAConstructors :: Name -> Q [Dec]
+ Data.Comp.Multi.Derive: smartConstructors :: Name -> Q [Dec]
+ Data.Comp.Multi.Desugar: class (HFunctor f, HFunctor g) => Desugar f g
+ Data.Comp.Multi.Desugar: desugHom :: Desugar f g => TermHom f g
+ Data.Comp.Multi.Desugar: desugHom' :: Desugar f g => Alg f (Context g a)
+ Data.Comp.Multi.Desugar: desugar :: Desugar f g => Term f :-> Term g
+ Data.Comp.Multi.Desugar: desugarA :: (HFunctor f', HFunctor g', DistAnn f p f', DistAnn g p g', Desugar f g) => Term f' :-> Term g'
+ Data.Comp.Multi.Desugar: instance [overlap ok] (Desugar f g[a1mbH], Desugar g g[a1mbH]) => Desugar (f :+: g) g[a1mbH]
+ Data.Comp.Multi.Desugar: instance [overlap ok] (HFunctor f, HFunctor g, f :<: g) => Desugar f g
+ Data.Comp.Multi.Generic: depth :: HFoldable f => Cxt h f a :=> Int
+ Data.Comp.Multi.Generic: query :: HFoldable f => (Term f :=> r) -> (r -> r -> r) -> Term f :=> r
+ Data.Comp.Multi.Generic: size :: HFoldable f => Cxt h f a :=> Int
+ Data.Comp.Multi.Generic: subs :: HFoldable f => Term f :=> [A (Term f)]
+ Data.Comp.Multi.Generic: subs' :: (HFoldable f, :<: g f) => Term f :=> [A (g (Term f))]
+ Data.Comp.Multi.Generic: subterms :: HFoldable f => Term f :=> [A (Term f)]
+ Data.Comp.Multi.Generic: subterms' :: (HFoldable f, :<: g f) => Term f :=> [A (g (Term f))]
+ Data.Comp.Multi.Generic: transform :: HFunctor f => (Term f :-> Term f) -> Term f :-> Term f
+ Data.Comp.Multi.Generic: transformM :: (HTraversable f, Monad m) => NatM m (Term f) (Term f) -> NatM m (Term f) (Term f)
+ Data.Comp.Multi.Ops: class DistAnn s :: ((* -> *) -> * -> *) p s' | s' -> s, s' -> p
+ Data.Comp.Multi.Ops: class RemA s :: ((* -> *) -> * -> *) s' | s -> s'
+ Data.Comp.Multi.Ops: injectA :: DistAnn s p s' => p -> s a :-> s' a
+ Data.Comp.Multi.Ops: instance [incoherent] DistAnn f p (f :&: p)
+ Data.Comp.Multi.Ops: instance [incoherent] DistAnn s p s' => DistAnn (f :+: s) p ((f :&: p) :+: s')
+ Data.Comp.Multi.Ops: instance [incoherent] RemA (f :&: p) f
+ Data.Comp.Multi.Ops: instance [incoherent] RemA s s' => RemA ((f :&: p) :+: s) (f :+: s')
+ Data.Comp.Multi.Ops: projectA :: DistAnn s p s' => s' a :-> (s a :&: p)
+ Data.Comp.Multi.Ops: remA :: RemA s s' => s a :-> s' a
+ Data.Comp.Multi.Sum: deepInject10 :: (HFunctor (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => CxtFun (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))) g
+ Data.Comp.Multi.Sum: deepInject4 :: (HFunctor (:+: f4 (:+: f3 (:+: f2 f1))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => CxtFun (:+: f4 (:+: f3 (:+: f2 f1))) g
+ Data.Comp.Multi.Sum: deepInject5 :: (HFunctor (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => CxtFun (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) g
+ Data.Comp.Multi.Sum: deepInject6 :: (HFunctor (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => CxtFun (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) g
+ Data.Comp.Multi.Sum: deepInject7 :: (HFunctor (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => CxtFun (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) g
+ Data.Comp.Multi.Sum: deepInject8 :: (HFunctor (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => CxtFun (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) g
+ Data.Comp.Multi.Sum: deepInject9 :: (HFunctor (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => CxtFun (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) g
+ Data.Comp.Multi.Sum: deepProject10 :: (HTraversable (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => CxtFunM Maybe f (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))))
+ Data.Comp.Multi.Sum: deepProject4 :: (HTraversable (:+: g4 (:+: g3 (:+: g2 g1))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => CxtFunM Maybe f (:+: g4 (:+: g3 (:+: g2 g1)))
+ Data.Comp.Multi.Sum: deepProject5 :: (HTraversable (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => CxtFunM Maybe f (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))
+ Data.Comp.Multi.Sum: deepProject6 :: (HTraversable (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => CxtFunM Maybe f (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))
+ Data.Comp.Multi.Sum: deepProject7 :: (HTraversable (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => CxtFunM Maybe f (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))
+ Data.Comp.Multi.Sum: deepProject8 :: (HTraversable (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => CxtFunM Maybe f (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))
+ Data.Comp.Multi.Sum: deepProject9 :: (HTraversable (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => CxtFunM Maybe f (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))
+ Data.Comp.Multi.Sum: inj10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) a i -> g a i
+ Data.Comp.Multi.Sum: inj4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) a i -> g a i
+ Data.Comp.Multi.Sum: inj5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) a i -> g a i
+ Data.Comp.Multi.Sum: inj6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) a i -> g a i
+ Data.Comp.Multi.Sum: inj7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) a i -> g a i
+ Data.Comp.Multi.Sum: inj8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) a i -> g a i
+ Data.Comp.Multi.Sum: inj9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) a i -> g a i
+ Data.Comp.Multi.Sum: inject10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) (Cxt h g a) i -> Cxt h g a i
+ Data.Comp.Multi.Sum: inject4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) (Cxt h g a) i -> Cxt h g a i
+ Data.Comp.Multi.Sum: inject5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) (Cxt h g a) i -> Cxt h g a i
+ Data.Comp.Multi.Sum: inject6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) (Cxt h g a) i -> Cxt h g a i
+ Data.Comp.Multi.Sum: inject7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) (Cxt h g a) i -> Cxt h g a i
+ Data.Comp.Multi.Sum: inject8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) (Cxt h g a) i -> Cxt h g a i
+ Data.Comp.Multi.Sum: inject9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) (Cxt h g a) i -> Cxt h g a i
+ Data.Comp.Multi.Sum: proj10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => f a i -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) a i)
+ Data.Comp.Multi.Sum: proj4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => f a i -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) a i)
+ Data.Comp.Multi.Sum: proj5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => f a i -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) a i)
+ Data.Comp.Multi.Sum: proj6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => f a i -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) a i)
+ Data.Comp.Multi.Sum: proj7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => f a i -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) a i)
+ Data.Comp.Multi.Sum: proj8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => f a i -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) a i)
+ Data.Comp.Multi.Sum: proj9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => f a i -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) a i)
+ Data.Comp.Multi.Sum: project10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => Cxt h f a i -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) (Cxt h f a) i)
+ Data.Comp.Multi.Sum: project4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => Cxt h f a i -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) (Cxt h f a) i)
+ Data.Comp.Multi.Sum: project5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => Cxt h f a i -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) (Cxt h f a) i)
+ Data.Comp.Multi.Sum: project6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => Cxt h f a i -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) (Cxt h f a) i)
+ Data.Comp.Multi.Sum: project7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => Cxt h f a i -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) (Cxt h f a) i)
+ Data.Comp.Multi.Sum: project8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => Cxt h f a i -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) (Cxt h f a) i)
+ Data.Comp.Multi.Sum: project9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => Cxt h f a i -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) (Cxt h f a) i)
+ Data.Comp.Multi.Term: instance [incoherent] HFoldable f => HFoldable (Cxt h f)
+ Data.Comp.Multi.Term: instance [incoherent] HTraversable f => HTraversable (Cxt h f)
+ Data.Comp.Multi.Variables: instance [overlap ok] (HasVars f v[a1ldN], HasVars g v[a1ldN]) => HasVars (f :+: g) v[a1ldN]
+ Data.Comp.MultiParam.Algebra: Compose :: f (g a) -> Compose a
+ Data.Comp.MultiParam.Algebra: appCxt :: HDifunctor f => Cxt Hole f a (Cxt h f a b) :-> Cxt h f a b
+ Data.Comp.MultiParam.Algebra: appSigFun :: HDifunctor f => SigFun f g -> CxtFun f g
+ Data.Comp.MultiParam.Algebra: appSigFun' :: HDifunctor g => SigFun f g -> CxtFun f g
+ Data.Comp.MultiParam.Algebra: appSigFunM :: (HDitraversable f m Any, Monad m) => SigFunM m f g -> CxtFunM m f g
+ Data.Comp.MultiParam.Algebra: appSigFunM' :: (HDitraversable g m Any, Monad m) => SigFunM m f g -> CxtFunM m f g
+ Data.Comp.MultiParam.Algebra: appTermHom :: (HDifunctor f, HDifunctor g) => TermHom f g -> CxtFun f g
+ Data.Comp.MultiParam.Algebra: appTermHom' :: HDifunctor g => TermHom f g -> CxtFun f g
+ Data.Comp.MultiParam.Algebra: appTermHomM :: (HDitraversable f m Any, HDifunctor g, Monad m) => TermHomM m f g -> CxtFunM m f g
+ Data.Comp.MultiParam.Algebra: appTermHomM' :: (HDitraversable g m Any, Monad m) => TermHomM m f g -> CxtFunM m f g
+ Data.Comp.MultiParam.Algebra: cata :: HDifunctor f => Alg f a -> Term f :-> a
+ Data.Comp.MultiParam.Algebra: cata' :: HDifunctor f => Alg f a -> Cxt h f a a :-> a
+ Data.Comp.MultiParam.Algebra: cataM :: (HDitraversable f m a, Monad m) => AlgM m f a -> NatM m (Term f) a
+ Data.Comp.MultiParam.Algebra: cataM' :: (HDifunctor f, Monad m) => AlgM' m f a -> NatM m (Term f) a
+ Data.Comp.MultiParam.Algebra: compAlg :: (HDifunctor f, HDifunctor g) => Alg g a -> TermHom f g -> Alg f a
+ Data.Comp.MultiParam.Algebra: compAlgM :: (HDitraversable g m a, Monad m) => AlgM m g a -> TermHomM m f g -> AlgM m f a
+ Data.Comp.MultiParam.Algebra: compAlgM' :: (HDitraversable g m a, Monad m) => AlgM m g a -> TermHom f g -> AlgM m f a
+ Data.Comp.MultiParam.Algebra: compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
+ Data.Comp.MultiParam.Algebra: compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h
+ Data.Comp.MultiParam.Algebra: compTermHom :: (HDifunctor g, HDifunctor h) => TermHom g h -> TermHom f g -> TermHom f h
+ Data.Comp.MultiParam.Algebra: compTermHomM :: (HDitraversable g m Any, HDifunctor h, Monad m) => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
+ Data.Comp.MultiParam.Algebra: free :: HDifunctor f => Alg f a -> (b :-> a) -> Cxt h f a b :-> a
+ Data.Comp.MultiParam.Algebra: freeM :: (HDitraversable f m a, Monad m) => AlgM m f a -> NatM m b a -> NatM m (Cxt h f a b) a
+ Data.Comp.MultiParam.Algebra: freeM' :: (HDifunctor f, Monad m) => AlgM' m f a -> NatM m b a -> NatM m (Cxt h f a b) a
+ Data.Comp.MultiParam.Algebra: getCompose :: Compose a -> f (g a)
+ Data.Comp.MultiParam.Algebra: newtype Compose f :: (* -> *) g :: (* -> *) a :: (* -> *) -> (* -> *) -> * -> *
+ Data.Comp.MultiParam.Algebra: sigFunM :: Monad m => SigFun f g -> SigFunM m f g
+ Data.Comp.MultiParam.Algebra: termHom :: HDifunctor g => SigFun f g -> TermHom f g
+ Data.Comp.MultiParam.Algebra: termHom' :: (HDifunctor f, HDifunctor g, Monad m) => SigFunM m f g -> TermHomM m f g
+ Data.Comp.MultiParam.Algebra: termHomM :: (HDifunctor g, Monad m) => SigFun f g -> TermHomM m f g
+ Data.Comp.MultiParam.Algebra: type Alg f a = f a a :-> a
+ Data.Comp.MultiParam.Algebra: type AlgM m f a = NatM m (f a a) a
+ Data.Comp.MultiParam.Algebra: type AlgM' m f a = NatM m (f a (Compose m a)) a
+ Data.Comp.MultiParam.Algebra: type CxtFun f g = forall h. SigFun (Cxt h f) (Cxt h g)
+ Data.Comp.MultiParam.Algebra: type CxtFunM m f g = forall h. SigFunM m (Cxt h f) (Cxt h g)
+ Data.Comp.MultiParam.Algebra: type SigFun f g = forall a b. f a b :-> g a b
+ Data.Comp.MultiParam.Algebra: type SigFunM m f g = forall a b. NatM m (f a b) (g a b)
+ Data.Comp.MultiParam.Algebra: type TermHom f g = SigFun f (Context g)
+ Data.Comp.MultiParam.Algebra: type TermHomM m f g = SigFunM m f (Cxt Hole g)
+ Data.Comp.MultiParam.Annotation: (:&:) :: f a b i -> p -> :&: f p i
+ Data.Comp.MultiParam.Annotation: (:*:) :: f a b -> g a b -> :*: f g a b
+ Data.Comp.MultiParam.Annotation: ann :: (DistAnn f p g, HDifunctor f) => p -> CxtFun f g
+ Data.Comp.MultiParam.Annotation: class DistAnn s :: ((* -> *) -> (* -> *) -> * -> *) p s' | s' -> s, s' -> p
+ Data.Comp.MultiParam.Annotation: class RemA s :: ((* -> *) -> (* -> *) -> * -> *) s' | s -> s'
+ Data.Comp.MultiParam.Annotation: data (:*:) f g a b
+ Data.Comp.MultiParam.Annotation: injectA :: DistAnn s p s' => p -> s a b :-> s' a b
+ Data.Comp.MultiParam.Annotation: liftA :: RemA s s' => (s' a b :-> t) -> s a b :-> t
+ Data.Comp.MultiParam.Annotation: liftA' :: (DistAnn s' p s, HDifunctor s') => (s' a b :-> Cxt h s' c d) -> s a b :-> Cxt h s c d
+ Data.Comp.MultiParam.Annotation: project' :: (:<: s f, RemA s s') => Cxt h f a b i -> Maybe (s' a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Annotation: projectA :: DistAnn s p s' => s' a b :-> (s a b :&: p)
+ Data.Comp.MultiParam.Annotation: propAnn :: (DistAnn f p f', DistAnn g p g', HDifunctor g) => TermHom f g -> TermHom f' g'
+ Data.Comp.MultiParam.Annotation: propAnnM :: (DistAnn f p f', DistAnn g p g', HDifunctor g, Monad m) => TermHomM m f g -> TermHomM m f' g'
+ Data.Comp.MultiParam.Annotation: remA :: RemA s s' => s a b :-> s' a b
+ Data.Comp.MultiParam.Annotation: stripA :: (RemA g f, HDifunctor g) => CxtFun g f
+ Data.Comp.MultiParam.Any: data Any :: * -> *
+ Data.Comp.MultiParam.Derive: caseHD :: (f a b i -> c) -> (g a b i -> c) -> (f :+: g) a b i -> c
+ Data.Comp.MultiParam.Derive: class EqHD f
+ Data.Comp.MultiParam.Derive: class HDifunctor f
+ Data.Comp.MultiParam.Derive: class HFunctor h => HFoldable h
+ Data.Comp.MultiParam.Derive: class HFoldable t => HTraversable t
+ Data.Comp.MultiParam.Derive: class EqHD f => OrdHD f
+ Data.Comp.MultiParam.Derive: class PShow a
+ Data.Comp.MultiParam.Derive: class ShowHD f
+ Data.Comp.MultiParam.Derive: compareHD :: (OrdHD f, POrd a) => f Var a i -> f Var a j -> FreshM Ordering
+ Data.Comp.MultiParam.Derive: derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]
+ Data.Comp.MultiParam.Derive: eqHD :: (EqHD f, PEq a) => f Var a i -> f Var a j -> FreshM Bool
+ Data.Comp.MultiParam.Derive: liftSum :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: makeEqHD :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: makeHDifunctor :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: makeHFoldable :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: makeHTraversable :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: makeOrdHD :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: makeShowHD :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: pshow :: PShow a => a i -> FreshM String
+ Data.Comp.MultiParam.Derive: showHD :: (ShowHD f, PShow a) => f Var a i -> FreshM String
+ Data.Comp.MultiParam.Derive: smartAConstructors :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Derive: smartConstructors :: Name -> Q [Dec]
+ Data.Comp.MultiParam.Desugar: class (HDifunctor f, HDifunctor g) => Desugar f g
+ Data.Comp.MultiParam.Desugar: desugHom :: Desugar f g => TermHom f g
+ Data.Comp.MultiParam.Desugar: desugHom' :: Desugar f g => f a (Cxt h g a b) :-> Cxt h g a b
+ Data.Comp.MultiParam.Desugar: desugar :: Desugar f g => Term f :-> Term g
+ Data.Comp.MultiParam.Desugar: desugarA :: (HDifunctor f', HDifunctor g', DistAnn f p f', DistAnn g p g', Desugar f g) => Term f' :-> Term g'
+ Data.Comp.MultiParam.Desugar: instance [overlap ok] (Desugar f g[a1EGf], Desugar g g[a1EGf]) => Desugar (f :+: g) g[a1EGf]
+ Data.Comp.MultiParam.Desugar: instance [overlap ok] (HDifunctor f, HDifunctor g, f :<: g) => Desugar f g
+ Data.Comp.MultiParam.Equality: class EqHD f
+ Data.Comp.MultiParam.Equality: class PEq a
+ Data.Comp.MultiParam.Equality: eqHD :: (EqHD f, PEq a) => f Var a i -> f Var a j -> FreshM Bool
+ Data.Comp.MultiParam.Equality: instance [incoherent] (EqHD f, EqHD g) => EqHD (f :+: g)
+ Data.Comp.MultiParam.Equality: instance [incoherent] (EqHD f, PEq a) => PEq (Cxt h f Var a)
+ Data.Comp.MultiParam.Equality: instance [incoherent] (HDifunctor f, EqHD f) => Eq (Term f i)
+ Data.Comp.MultiParam.Equality: instance [incoherent] Eq a => PEq (K a)
+ Data.Comp.MultiParam.Equality: instance [incoherent] EqHD f => EqHD (Cxt h f)
+ Data.Comp.MultiParam.Equality: instance [incoherent] PEq Var
+ Data.Comp.MultiParam.Equality: peq :: PEq a => a i -> a j -> FreshM Bool
+ Data.Comp.MultiParam.FreshM: data FreshM a
+ Data.Comp.MultiParam.FreshM: data Var i
+ Data.Comp.MultiParam.FreshM: evalFreshM :: FreshM a -> a
+ Data.Comp.MultiParam.FreshM: genVar :: FreshM (Var i)
+ Data.Comp.MultiParam.FreshM: instance Monad FreshM
+ Data.Comp.MultiParam.FreshM: varCoerce :: Var i -> Var j
+ Data.Comp.MultiParam.FreshM: varCompare :: Var i -> Var j -> Ordering
+ Data.Comp.MultiParam.FreshM: varEq :: Var i -> Var j -> Bool
+ Data.Comp.MultiParam.FreshM: varShow :: Var i -> String
+ Data.Comp.MultiParam.HDifunctor: A :: f i -> A f
+ Data.Comp.MultiParam.HDifunctor: I :: a -> I a
+ Data.Comp.MultiParam.HDifunctor: K :: a -> K a i
+ Data.Comp.MultiParam.HDifunctor: class HDifunctor f
+ Data.Comp.MultiParam.HDifunctor: class HFunctor h
+ Data.Comp.MultiParam.HDifunctor: data A f
+ Data.Comp.MultiParam.HDifunctor: data I a
+ Data.Comp.MultiParam.HDifunctor: data K a i
+ Data.Comp.MultiParam.HDifunctor: hdimap :: HDifunctor f => (a :-> b) -> (c :-> d) -> f b c :-> f a d
+ Data.Comp.MultiParam.HDifunctor: hfmap :: HFunctor h => (f :-> g) -> h f :-> h g
+ Data.Comp.MultiParam.HDifunctor: instance Eq a => Eq (K a i)
+ Data.Comp.MultiParam.HDifunctor: instance Functor (K a)
+ Data.Comp.MultiParam.HDifunctor: instance Functor I
+ Data.Comp.MultiParam.HDifunctor: instance HDifunctor f => HFunctor (f a)
+ Data.Comp.MultiParam.HDifunctor: instance Ord a => Ord (K a i)
+ Data.Comp.MultiParam.HDifunctor: type :-> f g = forall i. f i -> g i
+ Data.Comp.MultiParam.HDifunctor: type NatM m f g = forall i. f i -> m (g i)
+ Data.Comp.MultiParam.HDifunctor: unA :: A f -> f i
+ Data.Comp.MultiParam.HDifunctor: unI :: I a -> a
+ Data.Comp.MultiParam.HDifunctor: unK :: K a i -> a
+ Data.Comp.MultiParam.HDitraversable: class (HDifunctor f, Monad m) => HDitraversable f m a
+ Data.Comp.MultiParam.HDitraversable: class HFoldable t => HTraversable t
+ Data.Comp.MultiParam.HDitraversable: hdimapM :: HDitraversable f m a => NatM m b c -> NatM m (f a b) (f a c)
+ Data.Comp.MultiParam.HDitraversable: hmapM :: (HTraversable t, Monad m) => NatM m a b -> NatM m (t a) (t b)
+ Data.Comp.MultiParam.HDitraversable: htraverse :: (HTraversable t, Applicative f) => NatM f a b -> NatM f (t a) (t b)
+ Data.Comp.MultiParam.HDitraversable: instance [overlap ok] (HDifunctor f, Monad m, HTraversable (f a)) => HDitraversable f m a
+ Data.Comp.MultiParam.Ops: (:&:) :: f a b i -> p -> :&: f p i
+ Data.Comp.MultiParam.Ops: (:*:) :: f a b -> g a b -> :*: f g a b
+ Data.Comp.MultiParam.Ops: Inl :: (f a b i) -> :+: f g i
+ Data.Comp.MultiParam.Ops: Inr :: (g a b i) -> :+: f g i
+ Data.Comp.MultiParam.Ops: class :<: sub :: ((* -> *) -> (* -> *) -> * -> *) sup
+ Data.Comp.MultiParam.Ops: class DistAnn s :: ((* -> *) -> (* -> *) -> * -> *) p s' | s' -> s, s' -> p
+ Data.Comp.MultiParam.Ops: class RemA s :: ((* -> *) -> (* -> *) -> * -> *) s' | s -> s'
+ Data.Comp.MultiParam.Ops: data (:&:) f p a :: (* -> *) b :: (* -> *) i
+ Data.Comp.MultiParam.Ops: ffst :: (f :*: g) a b -> f a b
+ Data.Comp.MultiParam.Ops: fsnd :: (f :*: g) a b -> g a b
+ Data.Comp.MultiParam.Ops: inj :: :<: sub sup => sub a b :-> sup a b
+ Data.Comp.MultiParam.Ops: injectA :: DistAnn s p s' => p -> s a b :-> s' a b
+ Data.Comp.MultiParam.Ops: instance [incoherent] (HDifunctor f, HDifunctor g) => HDifunctor (f :+: g)
+ Data.Comp.MultiParam.Ops: instance [incoherent] (HDitraversable f m a, HDitraversable g m a) => HDitraversable (f :+: g) m a
+ Data.Comp.MultiParam.Ops: instance [incoherent] DistAnn f p (f :&: p)
+ Data.Comp.MultiParam.Ops: instance [incoherent] DistAnn s p s' => DistAnn (f :+: s) p ((f :&: p) :+: s')
+ Data.Comp.MultiParam.Ops: instance [incoherent] HDifunctor f => HDifunctor (f :&: p)
+ Data.Comp.MultiParam.Ops: instance [incoherent] HDitraversable f m a => HDitraversable (f :&: p) m a
+ Data.Comp.MultiParam.Ops: instance [incoherent] RemA (f :&: p) f
+ Data.Comp.MultiParam.Ops: instance [incoherent] RemA s s' => RemA ((f :&: p) :+: s) (f :+: s')
+ Data.Comp.MultiParam.Ops: instance [incoherent] f :<: (f :+: g)
+ Data.Comp.MultiParam.Ops: instance [incoherent] f :<: f
+ Data.Comp.MultiParam.Ops: instance [incoherent] f :<: g => f :<: (h :+: g)
+ Data.Comp.MultiParam.Ops: proj :: :<: sub sup => NatM Maybe (sup a b) (sub a b)
+ Data.Comp.MultiParam.Ops: projectA :: DistAnn s p s' => s' a b :-> (s a b :&: p)
+ Data.Comp.MultiParam.Ops: remA :: RemA s s' => s a b :-> s' a b
+ Data.Comp.MultiParam.Ordering: class EqHD f => OrdHD f
+ Data.Comp.MultiParam.Ordering: class PEq a => POrd a
+ Data.Comp.MultiParam.Ordering: compareHD :: (OrdHD f, POrd a) => f Var a i -> f Var a j -> FreshM Ordering
+ Data.Comp.MultiParam.Ordering: instance [incoherent] (HDifunctor f, OrdHD f) => Ord (Term f i)
+ Data.Comp.MultiParam.Ordering: instance [incoherent] (OrdHD f, OrdHD g) => OrdHD (f :+: g)
+ Data.Comp.MultiParam.Ordering: instance [incoherent] (OrdHD f, POrd a) => POrd (Cxt h f Var a)
+ Data.Comp.MultiParam.Ordering: instance [incoherent] Ord a => POrd (K a)
+ Data.Comp.MultiParam.Ordering: instance [incoherent] OrdHD f => OrdHD (Cxt h f)
+ Data.Comp.MultiParam.Ordering: instance [incoherent] POrd Var
+ Data.Comp.MultiParam.Ordering: pcompare :: POrd a => a i -> a j -> FreshM Ordering
+ Data.Comp.MultiParam.Show: class PShow a
+ Data.Comp.MultiParam.Show: class ShowHD f
+ Data.Comp.MultiParam.Show: instance [incoherent] (HDifunctor f, ShowHD f) => Show (Term f i)
+ Data.Comp.MultiParam.Show: instance [incoherent] (ShowHD f, PShow (K p)) => ShowHD (f :&: p)
+ Data.Comp.MultiParam.Show: instance [incoherent] (ShowHD f, PShow a) => PShow (Cxt h f Var a)
+ Data.Comp.MultiParam.Show: instance [incoherent] (ShowHD f, ShowHD g) => ShowHD (f :+: g)
+ Data.Comp.MultiParam.Show: instance [incoherent] PShow Var
+ Data.Comp.MultiParam.Show: instance [incoherent] Show a => PShow (K a)
+ Data.Comp.MultiParam.Show: pshow :: PShow a => a i -> FreshM String
+ Data.Comp.MultiParam.Show: showHD :: (ShowHD f, PShow a) => f Var a i -> FreshM String
+ Data.Comp.MultiParam.Sum: class :<: sub :: ((* -> *) -> (* -> *) -> * -> *) sup
+ Data.Comp.MultiParam.Sum: data (:+:) f g a :: (* -> *) b :: (* -> *) i
+ Data.Comp.MultiParam.Sum: deepInject :: (HDifunctor g, :<: g f) => CxtFun g f
+ Data.Comp.MultiParam.Sum: deepInject10 :: (HDifunctor (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => CxtFun (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))) g
+ Data.Comp.MultiParam.Sum: deepInject2 :: (HDifunctor (:+: f2 f1), :<: f1 g, :<: f2 g) => CxtFun (:+: f2 f1) g
+ Data.Comp.MultiParam.Sum: deepInject3 :: (HDifunctor (:+: f3 (:+: f2 f1)), :<: f1 g, :<: f2 g, :<: f3 g) => CxtFun (:+: f3 (:+: f2 f1)) g
+ Data.Comp.MultiParam.Sum: deepInject4 :: (HDifunctor (:+: f4 (:+: f3 (:+: f2 f1))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => CxtFun (:+: f4 (:+: f3 (:+: f2 f1))) g
+ Data.Comp.MultiParam.Sum: deepInject5 :: (HDifunctor (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => CxtFun (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) g
+ Data.Comp.MultiParam.Sum: deepInject6 :: (HDifunctor (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => CxtFun (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) g
+ Data.Comp.MultiParam.Sum: deepInject7 :: (HDifunctor (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => CxtFun (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) g
+ Data.Comp.MultiParam.Sum: deepInject8 :: (HDifunctor (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => CxtFun (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) g
+ Data.Comp.MultiParam.Sum: deepInject9 :: (HDifunctor (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => CxtFun (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) g
+ Data.Comp.MultiParam.Sum: deepProject :: (HDitraversable g Maybe Any, :<: g f) => CxtFunM Maybe f g
+ Data.Comp.MultiParam.Sum: deepProject10 :: (HDitraversable (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => CxtFunM Maybe f (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))))
+ Data.Comp.MultiParam.Sum: deepProject2 :: (HDitraversable (:+: g2 g1) Maybe Any, :<: g1 f, :<: g2 f) => CxtFunM Maybe f (:+: g2 g1)
+ Data.Comp.MultiParam.Sum: deepProject3 :: (HDitraversable (:+: g3 (:+: g2 g1)) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f) => CxtFunM Maybe f (:+: g3 (:+: g2 g1))
+ Data.Comp.MultiParam.Sum: deepProject4 :: (HDitraversable (:+: g4 (:+: g3 (:+: g2 g1))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => CxtFunM Maybe f (:+: g4 (:+: g3 (:+: g2 g1)))
+ Data.Comp.MultiParam.Sum: deepProject5 :: (HDitraversable (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => CxtFunM Maybe f (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))
+ Data.Comp.MultiParam.Sum: deepProject6 :: (HDitraversable (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => CxtFunM Maybe f (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))
+ Data.Comp.MultiParam.Sum: deepProject7 :: (HDitraversable (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => CxtFunM Maybe f (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))
+ Data.Comp.MultiParam.Sum: deepProject8 :: (HDitraversable (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => CxtFunM Maybe f (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))
+ Data.Comp.MultiParam.Sum: deepProject9 :: (HDitraversable (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => CxtFunM Maybe f (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))
+ Data.Comp.MultiParam.Sum: inj :: :<: sub sup => sub a b :-> sup a b
+ Data.Comp.MultiParam.Sum: inj10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inj9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) a b i -> g a b i
+ Data.Comp.MultiParam.Sum: inject :: :<: g f => g a (Cxt h f a b) :-> Cxt h f a b
+ Data.Comp.MultiParam.Sum: inject10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: inject9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) a (Cxt h g a b) i -> Cxt h g a b i
+ Data.Comp.MultiParam.Sum: injectConst :: (HDifunctor g, :<: g f) => Const g :-> Cxt h f Any a
+ Data.Comp.MultiParam.Sum: injectConst2 :: (HDifunctor f1, HDifunctor f2, HDifunctor g, :<: f1 g, :<: f2 g) => Const (f1 :+: f2) :-> Cxt h g Any a
+ Data.Comp.MultiParam.Sum: injectConst3 :: (HDifunctor f1, HDifunctor f2, HDifunctor f3, HDifunctor g, :<: f1 g, :<: f2 g, :<: f3 g) => Const (f1 :+: (f2 :+: f3)) :-> Cxt h g Any a
+ Data.Comp.MultiParam.Sum: injectCxt :: (HDifunctor g, :<: g f) => Cxt h g a (Cxt h f a b) :-> Cxt h f a b
+ Data.Comp.MultiParam.Sum: instance [incoherent] (Eq (f a b i), Eq (g a b i)) => Eq ((:+:) f g a b i)
+ Data.Comp.MultiParam.Sum: instance [incoherent] (Ord (f a b i), Ord (g a b i)) => Ord ((:+:) f g a b i)
+ Data.Comp.MultiParam.Sum: instance [incoherent] (Show (f a b i), Show (g a b i)) => Show ((:+:) f g a b i)
+ Data.Comp.MultiParam.Sum: liftCxt :: (HDifunctor f, :<: g f) => g a b :-> Cxt Hole f a b
+ Data.Comp.MultiParam.Sum: proj :: :<: sub sup => NatM Maybe (sup a b) (sub a b)
+ Data.Comp.MultiParam.Sum: proj10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => f a b i -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) a b i)
+ Data.Comp.MultiParam.Sum: proj2 :: (:<: g1 f, :<: g2 f) => f a b i -> Maybe (:+: g2 g1 a b i)
+ Data.Comp.MultiParam.Sum: proj3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => f a b i -> Maybe (:+: g3 (:+: g2 g1) a b i)
+ Data.Comp.MultiParam.Sum: proj4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => f a b i -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) a b i)
+ Data.Comp.MultiParam.Sum: proj5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => f a b i -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) a b i)
+ Data.Comp.MultiParam.Sum: proj6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => f a b i -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) a b i)
+ Data.Comp.MultiParam.Sum: proj7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => f a b i -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) a b i)
+ Data.Comp.MultiParam.Sum: proj8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => f a b i -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) a b i)
+ Data.Comp.MultiParam.Sum: proj9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => f a b i -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) a b i)
+ Data.Comp.MultiParam.Sum: project :: :<: g f => NatM Maybe (Cxt h f a b) (g a (Cxt h f a b))
+ Data.Comp.MultiParam.Sum: project10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => Cxt h f a b i -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project2 :: (:<: g1 f, :<: g2 f) => Cxt h f a b i -> Maybe (:+: g2 g1 a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => Cxt h f a b i -> Maybe (:+: g3 (:+: g2 g1) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => Cxt h f a b i -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => Cxt h f a b i -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => Cxt h f a b i -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => Cxt h f a b i -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => Cxt h f a b i -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: project9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => Cxt h f a b i -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) a (Cxt h f a b) i)
+ Data.Comp.MultiParam.Sum: projectConst :: (HDifunctor g, :<: g f) => NatM Maybe (Cxt h f Any a) (Const g)
+ Data.Comp.MultiParam.Term: Hole :: b i -> Cxt Hole f a b i
+ Data.Comp.MultiParam.Term: Place :: a i -> Cxt h f a b i
+ Data.Comp.MultiParam.Term: Term :: f a (Cxt h f a b) i -> Cxt h f a b i
+ Data.Comp.MultiParam.Term: coerceCxt :: Cxt h f Any b i -> forall a. Cxt h f a b i
+ Data.Comp.MultiParam.Term: constTerm :: HDifunctor f => Const f :-> Term f
+ Data.Comp.MultiParam.Term: data Any :: * -> *
+ Data.Comp.MultiParam.Term: data Cxt :: * -> ((* -> *) -> (* -> *) -> * -> *) -> (* -> *) -> (* -> *) -> * -> *
+ Data.Comp.MultiParam.Term: data Hole
+ Data.Comp.MultiParam.Term: data NoHole
+ Data.Comp.MultiParam.Term: hdimapMCxt :: HDitraversable f m a => (NatM m b b') -> NatM m (Cxt h f a b) (Cxt h f a b')
+ Data.Comp.MultiParam.Term: hfmapCxt :: HDifunctor f => (b :-> b') -> Cxt h f a b :-> Cxt h f a b'
+ Data.Comp.MultiParam.Term: simpCxt :: HDifunctor f => f a b :-> Cxt Hole f a b
+ Data.Comp.MultiParam.Term: toCxt :: HDifunctor f => Trm f a :-> Cxt h f a b
+ Data.Comp.MultiParam.Term: type Const f i = f Any (K ()) i
+ Data.Comp.MultiParam.Term: type Context = Cxt Hole
+ Data.Comp.MultiParam.Term: type Term f = Trm f Any
+ Data.Comp.MultiParam.Term: type Trm f a = Cxt NoHole f a (K ())
+ Data.Comp.Ops: class DistAnn s p s' | s' -> s, s' -> p
+ Data.Comp.Ops: class RemA s s' | s -> s'
+ Data.Comp.Ops: injectA :: DistAnn s p s' => p -> s a -> s' a
+ Data.Comp.Ops: instance [incoherent] DistAnn f p (f :&: p)
+ Data.Comp.Ops: instance [incoherent] DistAnn s p s' => DistAnn (f :+: s) p ((f :&: p) :+: s')
+ Data.Comp.Ops: instance [incoherent] RemA (f :&: p) f
+ Data.Comp.Ops: instance [incoherent] RemA s s' => RemA ((f :&: p) :+: s) (f :+: s')
+ Data.Comp.Ops: projectA :: DistAnn s p s' => s' a -> (s a, p)
+ Data.Comp.Ops: remA :: RemA s s' => s a -> s' a
+ Data.Comp.Param.Algebra: algM :: (Ditraversable f m a, Monad m) => AlgM m f a -> Alg f (m a)
+ Data.Comp.Param.Algebra: ana :: Difunctor f => Coalg f a -> a -> Term f
+ Data.Comp.Param.Algebra: anaM :: (Ditraversable f m Any, Monad m) => CoalgM m f a -> a -> m (Term f)
+ Data.Comp.Param.Algebra: apo :: Difunctor f => RCoalg f a -> a -> Term f
+ Data.Comp.Param.Algebra: apoM :: (Ditraversable f m Any, Monad m) => RCoalgM m f a -> a -> m (Term f)
+ Data.Comp.Param.Algebra: appCxt :: Difunctor f => Context f a (Cxt h f a b) -> Cxt h f a b
+ Data.Comp.Param.Algebra: appSigFun :: Difunctor f => SigFun f g -> CxtFun f g
+ Data.Comp.Param.Algebra: appSigFun' :: Difunctor g => SigFun f g -> CxtFun f g
+ Data.Comp.Param.Algebra: appSigFunM :: Ditraversable f m Any => SigFunM m f g -> CxtFunM m f g
+ Data.Comp.Param.Algebra: appSigFunM' :: Ditraversable g m Any => SigFunM m f g -> CxtFunM m f g
+ Data.Comp.Param.Algebra: appSigFunMD :: (Ditraversable f m Any, Difunctor g, Monad m) => SigFunMD m f g -> CxtFunM m f g
+ Data.Comp.Param.Algebra: appTermHom :: (Difunctor f, Difunctor g) => TermHom f g -> CxtFun f g
+ Data.Comp.Param.Algebra: appTermHom' :: Difunctor g => TermHom f g -> CxtFun f g
+ Data.Comp.Param.Algebra: appTermHomM :: (Ditraversable f m Any, Difunctor g) => TermHomM m f g -> CxtFunM m f g
+ Data.Comp.Param.Algebra: appTermHomM' :: Ditraversable g m Any => TermHomM m f g -> CxtFunM m f g
+ Data.Comp.Param.Algebra: cata :: Difunctor f => Alg f a -> Term f -> a
+ Data.Comp.Param.Algebra: cata' :: Difunctor f => Alg f a -> Cxt h f a a -> a
+ Data.Comp.Param.Algebra: cataM :: (Ditraversable f m a, Monad m) => AlgM m f a -> Term f -> m a
+ Data.Comp.Param.Algebra: cataM' :: (Ditraversable f m a, Monad m) => AlgM m f a -> Cxt h f a (m a) -> m a
+ Data.Comp.Param.Algebra: compAlg :: (Difunctor f, Difunctor g) => Alg g a -> TermHom f g -> Alg f a
+ Data.Comp.Param.Algebra: compAlgM :: (Ditraversable g m a, Monad m) => AlgM m g a -> TermHomM m f g -> AlgM m f a
+ Data.Comp.Param.Algebra: compAlgM' :: (Ditraversable g m a, Monad m) => AlgM m g a -> TermHom f g -> AlgM m f a
+ Data.Comp.Param.Algebra: compAlgSigFun :: Alg g a -> SigFun f g -> Alg f a
+ Data.Comp.Param.Algebra: compAlgSigFunM :: Monad m => AlgM m g a -> SigFunM m f g -> AlgM m f a
+ Data.Comp.Param.Algebra: compAlgSigFunM' :: AlgM m g a -> SigFun f g -> AlgM m f a
+ Data.Comp.Param.Algebra: compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
+ Data.Comp.Param.Algebra: compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h
+ Data.Comp.Param.Algebra: compSigFunTermHom :: Difunctor g => SigFun g h -> TermHom f g -> TermHom f h
+ Data.Comp.Param.Algebra: compSigFunTermHomM :: Ditraversable g m Any => SigFunM m g h -> TermHomM m f g -> TermHomM m f h
+ Data.Comp.Param.Algebra: compTermHom :: (Difunctor g, Difunctor h) => TermHom g h -> TermHom f g -> TermHom f h
+ Data.Comp.Param.Algebra: compTermHomM :: (Ditraversable g m Any, Difunctor h, Monad m) => TermHomM m g h -> TermHomM m f g -> TermHomM m f h
+ Data.Comp.Param.Algebra: compTermHomSigFun :: TermHom g h -> SigFun f g -> TermHom f h
+ Data.Comp.Param.Algebra: free :: Difunctor f => Alg f a -> (b -> a) -> Cxt h f a b -> a
+ Data.Comp.Param.Algebra: freeM :: (Ditraversable f m a, Monad m) => AlgM m f a -> (b -> m a) -> Cxt h f a b -> m a
+ Data.Comp.Param.Algebra: futu :: Difunctor f => CVCoalg f a -> a -> Term f
+ Data.Comp.Param.Algebra: futu' :: Difunctor f => CVCoalg' f a -> a -> Term f
+ Data.Comp.Param.Algebra: futuM :: (Ditraversable f m Any, Monad m) => CVCoalgM m f a -> a -> m (Term f)
+ Data.Comp.Param.Algebra: histo :: (Difunctor f, DistAnn f a f') => CVAlg f a f' -> Term f -> a
+ Data.Comp.Param.Algebra: histoM :: (Ditraversable f m a, Monad m, DistAnn f a f') => CVAlgM m f a f' -> Term f -> m a
+ Data.Comp.Param.Algebra: para :: Difunctor f => RAlg f a -> Term f -> a
+ Data.Comp.Param.Algebra: paraM :: (Ditraversable f m a, Monad m) => RAlgM m f a -> Term f -> m a
+ Data.Comp.Param.Algebra: sigFunM :: Monad m => SigFun f g -> SigFunM m f g
+ Data.Comp.Param.Algebra: termHom :: Difunctor g => SigFun f g -> TermHom f g
+ Data.Comp.Param.Algebra: termHomM :: (Difunctor g, Monad m) => SigFunM m f g -> TermHomM m f g
+ Data.Comp.Param.Algebra: termHomMD :: (Difunctor f, Difunctor g, Monad m) => TermHomMD m f g -> CxtFunM m f g
+ Data.Comp.Param.Algebra: type Alg f a = f a a -> a
+ Data.Comp.Param.Algebra: type AlgM m f a = f a a -> m a
+ Data.Comp.Param.Algebra: type CVAlg f a f' = f a (Trm f' a) -> a
+ Data.Comp.Param.Algebra: type CVAlgM m f a f' = f a (Trm f' a) -> m a
+ Data.Comp.Param.Algebra: type CVCoalg f a = forall b. a -> [(a, b)] -> Either b (f b (Context f b (a, [(a, b)])))
+ Data.Comp.Param.Algebra: type CVCoalg' f a = forall b. a -> [(a, b)] -> Context f b (a, [(a, b)])
+ Data.Comp.Param.Algebra: type CVCoalgM m f a = forall b. a -> [(a, b)] -> m (Either b (f b (Context f b (a, [(a, b)]))))
+ Data.Comp.Param.Algebra: type Coalg f a = forall b. a -> [(a, b)] -> Either b (f b (a, [(a, b)]))
+ Data.Comp.Param.Algebra: type CoalgM m f a = forall b. a -> [(a, b)] -> m (Either b (f b (a, [(a, b)])))
+ Data.Comp.Param.Algebra: type CxtFun f g = forall h a b. Cxt h f a b -> Cxt h g a b
+ Data.Comp.Param.Algebra: type CxtFunM m f g = forall h. SigFunM m (Cxt h f) (Cxt h g)
+ Data.Comp.Param.Algebra: type RAlg f a = f a (Trm f a, a) -> a
+ Data.Comp.Param.Algebra: type RAlgM m f a = f a (Trm f a, a) -> m a
+ Data.Comp.Param.Algebra: type RCoalg f a = forall b. a -> [(a, b)] -> Either b (f b (Either (Trm f b) (a, [(a, b)])))
+ Data.Comp.Param.Algebra: type RCoalgM m f a = forall b. a -> [(a, b)] -> m (Either b (f b (Either (Trm f b) (a, [(a, b)]))))
+ Data.Comp.Param.Algebra: type SigFun f g = forall a b. f a b -> g a b
+ Data.Comp.Param.Algebra: type SigFunM m f g = forall a b. f a b -> m (g a b)
+ Data.Comp.Param.Algebra: type SigFunMD m f g = forall a b. f a (m b) -> m (g a b)
+ Data.Comp.Param.Algebra: type TermHom f g = SigFun f (Context g)
+ Data.Comp.Param.Algebra: type TermHomM m f g = SigFunM m f (Context g)
+ Data.Comp.Param.Algebra: type TermHomMD m f g = SigFunMD m f (Context g)
+ Data.Comp.Param.Annotation: (:&:) :: f a b -> p -> :&: f p a b
+ Data.Comp.Param.Annotation: (:*:) :: f a b -> g a b -> :*: f g a b
+ Data.Comp.Param.Annotation: ann :: (DistAnn f p g, Difunctor f) => p -> CxtFun f g
+ Data.Comp.Param.Annotation: class DistAnn s p s' | s' -> s, s' -> p
+ Data.Comp.Param.Annotation: class RemA s s' | s -> s'
+ Data.Comp.Param.Annotation: data (:*:) f g a b
+ Data.Comp.Param.Annotation: injectA :: DistAnn s p s' => p -> s a b -> s' a b
+ Data.Comp.Param.Annotation: liftA :: RemA s s' => (s' a b -> t) -> s a b -> t
+ Data.Comp.Param.Annotation: liftA' :: (DistAnn s' p s, Difunctor s') => (s' a b -> Cxt h s' c d) -> s a b -> Cxt h s c d
+ Data.Comp.Param.Annotation: project' :: (:<: s f, RemA s s') => Cxt h f a b -> Maybe (s' a (Cxt h f a b))
+ Data.Comp.Param.Annotation: projectA :: DistAnn s p s' => s' a b -> (s a b, p)
+ Data.Comp.Param.Annotation: propAnn :: (DistAnn f p f', DistAnn g p g', Difunctor g) => TermHom f g -> TermHom f' g'
+ Data.Comp.Param.Annotation: propAnnM :: (DistAnn f p f', DistAnn g p g', Difunctor g, Monad m) => TermHomM m f g -> TermHomM m f' g'
+ Data.Comp.Param.Annotation: remA :: RemA s s' => s a b -> s' a b
+ Data.Comp.Param.Annotation: stripA :: (RemA g f, Difunctor g) => CxtFun g f
+ Data.Comp.Param.Any: data Any
+ Data.Comp.Param.Derive: caseD :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c
+ Data.Comp.Param.Derive: class Difunctor f
+ Data.Comp.Param.Derive: class (Difunctor f, Monad m) => Ditraversable f m a
+ Data.Comp.Param.Derive: class EqD f
+ Data.Comp.Param.Derive: class EqD f => OrdD f
+ Data.Comp.Param.Derive: class PShow a
+ Data.Comp.Param.Derive: class ShowD f
+ Data.Comp.Param.Derive: compareD :: (OrdD f, POrd a) => f Var a -> f Var a -> FreshM Ordering
+ Data.Comp.Param.Derive: derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]
+ Data.Comp.Param.Derive: eqD :: (EqD f, PEq a) => f Var a -> f Var a -> FreshM Bool
+ Data.Comp.Param.Derive: liftSum :: Name -> Q [Dec]
+ Data.Comp.Param.Derive: makeDifunctor :: Name -> Q [Dec]
+ Data.Comp.Param.Derive: makeDitraversable :: Name -> Q [Dec]
+ Data.Comp.Param.Derive: makeEqD :: Name -> Q [Dec]
+ Data.Comp.Param.Derive: makeOrdD :: Name -> Q [Dec]
+ Data.Comp.Param.Derive: makeShowD :: Name -> Q [Dec]
+ Data.Comp.Param.Derive: pshow :: PShow a => a -> FreshM String
+ Data.Comp.Param.Derive: showD :: (ShowD f, PShow a) => f Var a -> FreshM String
+ Data.Comp.Param.Derive: smartAConstructors :: Name -> Q [Dec]
+ Data.Comp.Param.Derive: smartConstructors :: Name -> Q [Dec]
+ Data.Comp.Param.Desugar: class (Difunctor f, Difunctor g) => Desugar f g
+ Data.Comp.Param.Desugar: desugHom :: Desugar f g => TermHom f g
+ Data.Comp.Param.Desugar: desugHom' :: Desugar f g => f a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Desugar: desugar :: Desugar f g => Term f -> Term g
+ Data.Comp.Param.Desugar: desugarA :: (Difunctor f', Difunctor g', DistAnn f p f', DistAnn g p g', Desugar f g) => Term f' -> Term g'
+ Data.Comp.Param.Desugar: instance [overlap ok] (Desugar f g[aZw0], Desugar g g[aZw0]) => Desugar (f :+: g) g[aZw0]
+ Data.Comp.Param.Desugar: instance [overlap ok] (Difunctor f, Difunctor g, f :<: g) => Desugar f g
+ Data.Comp.Param.Difunctor: class Difunctor f
+ Data.Comp.Param.Difunctor: dimap :: Difunctor f => (a -> b) -> (c -> d) -> f b c -> f a d
+ Data.Comp.Param.Difunctor: instance Difunctor (->)
+ Data.Comp.Param.Difunctor: instance Difunctor f => Functor (f a)
+ Data.Comp.Param.Ditraversable: class (Difunctor f, Monad m) => Ditraversable f m a
+ Data.Comp.Param.Ditraversable: dimapM :: Ditraversable f m a => (b -> m c) -> f a b -> m (f a c)
+ Data.Comp.Param.Ditraversable: disequence :: Ditraversable f m a => f a (m b) -> m (f a b)
+ Data.Comp.Param.Ditraversable: instance [overlap ok] (Error e, Ditraversable (->) m Any) => Ditraversable (->) (ErrorT e m) Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] (Monoid w, Ditraversable (->) m Any) => Ditraversable (->) (RWST r w s m) Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] (Monoid w, Ditraversable (->) m Any) => Ditraversable (->) (WriterT w m) Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) (Either e) Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) Gen a
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) Identity a
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) Maybe Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) [] Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) m Any => Ditraversable (->) (ListT m) Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) m Any => Ditraversable (->) (StateT s m) Any
+ Data.Comp.Param.Ditraversable: instance [overlap ok] Ditraversable (->) m a => Ditraversable (->) (ReaderT r m) a
+ Data.Comp.Param.Equality: class EqD f
+ Data.Comp.Param.Equality: class PEq a
+ Data.Comp.Param.Equality: eqD :: (EqD f, PEq a) => f Var a -> f Var a -> FreshM Bool
+ Data.Comp.Param.Equality: instance [incoherent] (Difunctor f, EqD f) => Eq (Term f)
+ Data.Comp.Param.Equality: instance [incoherent] (EqD f, EqD g) => EqD (f :+: g)
+ Data.Comp.Param.Equality: instance [incoherent] (EqD f, PEq a) => PEq (Cxt h f Var a)
+ Data.Comp.Param.Equality: instance [incoherent] Eq a => PEq a
+ Data.Comp.Param.Equality: instance [incoherent] EqD f => EqD (Cxt h f)
+ Data.Comp.Param.Equality: peq :: PEq a => a -> a -> FreshM Bool
+ Data.Comp.Param.FreshM: data FreshM a
+ Data.Comp.Param.FreshM: data Var
+ Data.Comp.Param.FreshM: evalFreshM :: FreshM a -> a
+ Data.Comp.Param.FreshM: genVar :: FreshM Var
+ Data.Comp.Param.FreshM: instance Eq Var
+ Data.Comp.Param.FreshM: instance Monad FreshM
+ Data.Comp.Param.FreshM: instance Ord Var
+ Data.Comp.Param.FreshM: instance Show Var
+ Data.Comp.Param.Ops: (:&:) :: f a b -> p -> :&: f p a b
+ Data.Comp.Param.Ops: (:*:) :: f a b -> g a b -> :*: f g a b
+ Data.Comp.Param.Ops: Inl :: (f a b) -> :+: f g a b
+ Data.Comp.Param.Ops: Inr :: (g a b) -> :+: f g a b
+ Data.Comp.Param.Ops: class :<: sub sup
+ Data.Comp.Param.Ops: class DistAnn s p s' | s' -> s, s' -> p
+ Data.Comp.Param.Ops: class RemA s s' | s -> s'
+ Data.Comp.Param.Ops: data (:&:) f p a b
+ Data.Comp.Param.Ops: ffst :: (f :*: g) a b -> f a b
+ Data.Comp.Param.Ops: fsnd :: (f :*: g) a b -> g a b
+ Data.Comp.Param.Ops: inj :: :<: sub sup => sub a b -> sup a b
+ Data.Comp.Param.Ops: injectA :: DistAnn s p s' => p -> s a b -> s' a b
+ Data.Comp.Param.Ops: instance [incoherent] (Difunctor f, Difunctor g) => Difunctor (f :+: g)
+ Data.Comp.Param.Ops: instance [incoherent] (Ditraversable f m a, Ditraversable g m a) => Ditraversable (f :+: g) m a
+ Data.Comp.Param.Ops: instance [incoherent] Difunctor f => Difunctor (f :&: p)
+ Data.Comp.Param.Ops: instance [incoherent] DistAnn f p (f :&: p)
+ Data.Comp.Param.Ops: instance [incoherent] DistAnn s p s' => DistAnn (f :+: s) p ((f :&: p) :+: s')
+ Data.Comp.Param.Ops: instance [incoherent] Ditraversable f m a => Ditraversable (f :&: p) m a
+ Data.Comp.Param.Ops: instance [incoherent] RemA (f :&: p) f
+ Data.Comp.Param.Ops: instance [incoherent] RemA s s' => RemA ((f :&: p) :+: s) (f :+: s')
+ Data.Comp.Param.Ops: instance [incoherent] f :<: (f :+: g)
+ Data.Comp.Param.Ops: instance [incoherent] f :<: f
+ Data.Comp.Param.Ops: instance [incoherent] f :<: g => f :<: (h :+: g)
+ Data.Comp.Param.Ops: proj :: :<: sub sup => sup a b -> Maybe (sub a b)
+ Data.Comp.Param.Ops: projectA :: DistAnn s p s' => s' a b -> (s a b, p)
+ Data.Comp.Param.Ops: remA :: RemA s s' => s a b -> s' a b
+ Data.Comp.Param.Ordering: class EqD f => OrdD f
+ Data.Comp.Param.Ordering: class PEq a => POrd a
+ Data.Comp.Param.Ordering: compareD :: (OrdD f, POrd a) => f Var a -> f Var a -> FreshM Ordering
+ Data.Comp.Param.Ordering: instance [incoherent] (Difunctor f, OrdD f) => Ord (Term f)
+ Data.Comp.Param.Ordering: instance [incoherent] (OrdD f, OrdD g) => OrdD (f :+: g)
+ Data.Comp.Param.Ordering: instance [incoherent] (OrdD f, POrd a) => POrd (Cxt h f Var a)
+ Data.Comp.Param.Ordering: instance [incoherent] Ord a => POrd a
+ Data.Comp.Param.Ordering: instance [incoherent] OrdD f => OrdD (Cxt h f)
+ Data.Comp.Param.Ordering: pcompare :: POrd a => a -> a -> FreshM Ordering
+ Data.Comp.Param.Show: class PShow a
+ Data.Comp.Param.Show: class ShowD f
+ Data.Comp.Param.Show: instance [incoherent] (Difunctor f, ShowD f) => Show (Term f)
+ Data.Comp.Param.Show: instance [incoherent] (ShowD f, PShow a) => PShow (Cxt h f Var a)
+ Data.Comp.Param.Show: instance [incoherent] (ShowD f, PShow p) => ShowD (f :&: p)
+ Data.Comp.Param.Show: instance [incoherent] (ShowD f, ShowD g) => ShowD (f :+: g)
+ Data.Comp.Param.Show: instance [incoherent] Show a => PShow a
+ Data.Comp.Param.Show: instance [incoherent] ShowD f => ShowD (Cxt h f)
+ Data.Comp.Param.Show: pshow :: PShow a => a -> FreshM String
+ Data.Comp.Param.Show: showD :: (ShowD f, PShow a) => f Var a -> FreshM String
+ Data.Comp.Param.Sum: class :<: sub sup
+ Data.Comp.Param.Sum: data (:+:) f g a b
+ Data.Comp.Param.Sum: deepInject :: (Difunctor g, :<: g f) => CxtFun g f
+ Data.Comp.Param.Sum: deepInject10 :: (Difunctor (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => CxtFun (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))) g
+ Data.Comp.Param.Sum: deepInject2 :: (Difunctor (:+: f2 f1), :<: f1 g, :<: f2 g) => CxtFun (:+: f2 f1) g
+ Data.Comp.Param.Sum: deepInject3 :: (Difunctor (:+: f3 (:+: f2 f1)), :<: f1 g, :<: f2 g, :<: f3 g) => CxtFun (:+: f3 (:+: f2 f1)) g
+ Data.Comp.Param.Sum: deepInject4 :: (Difunctor (:+: f4 (:+: f3 (:+: f2 f1))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => CxtFun (:+: f4 (:+: f3 (:+: f2 f1))) g
+ Data.Comp.Param.Sum: deepInject5 :: (Difunctor (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => CxtFun (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) g
+ Data.Comp.Param.Sum: deepInject6 :: (Difunctor (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => CxtFun (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) g
+ Data.Comp.Param.Sum: deepInject7 :: (Difunctor (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => CxtFun (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) g
+ Data.Comp.Param.Sum: deepInject8 :: (Difunctor (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => CxtFun (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) g
+ Data.Comp.Param.Sum: deepInject9 :: (Difunctor (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => CxtFun (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) g
+ Data.Comp.Param.Sum: deepProject :: (Ditraversable g Maybe Any, :<: g f) => CxtFunM Maybe f g
+ Data.Comp.Param.Sum: deepProject10 :: (Ditraversable (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => CxtFunM Maybe f (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))))
+ Data.Comp.Param.Sum: deepProject2 :: (Ditraversable (:+: g2 g1) Maybe Any, :<: g1 f, :<: g2 f) => CxtFunM Maybe f (:+: g2 g1)
+ Data.Comp.Param.Sum: deepProject3 :: (Ditraversable (:+: g3 (:+: g2 g1)) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f) => CxtFunM Maybe f (:+: g3 (:+: g2 g1))
+ Data.Comp.Param.Sum: deepProject4 :: (Ditraversable (:+: g4 (:+: g3 (:+: g2 g1))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => CxtFunM Maybe f (:+: g4 (:+: g3 (:+: g2 g1)))
+ Data.Comp.Param.Sum: deepProject5 :: (Ditraversable (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => CxtFunM Maybe f (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))
+ Data.Comp.Param.Sum: deepProject6 :: (Ditraversable (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => CxtFunM Maybe f (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))
+ Data.Comp.Param.Sum: deepProject7 :: (Ditraversable (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => CxtFunM Maybe f (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))
+ Data.Comp.Param.Sum: deepProject8 :: (Ditraversable (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => CxtFunM Maybe f (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))
+ Data.Comp.Param.Sum: deepProject9 :: (Ditraversable (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) Maybe Any, :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => CxtFunM Maybe f (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))
+ Data.Comp.Param.Sum: inj :: :<: sub sup => sub a b -> sup a b
+ Data.Comp.Param.Sum: inj10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) a b -> g a b
+ Data.Comp.Param.Sum: inj2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 a b -> g a b
+ Data.Comp.Param.Sum: inj3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) a b -> g a b
+ Data.Comp.Param.Sum: inj4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) a b -> g a b
+ Data.Comp.Param.Sum: inj5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) a b -> g a b
+ Data.Comp.Param.Sum: inj6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) a b -> g a b
+ Data.Comp.Param.Sum: inj7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) a b -> g a b
+ Data.Comp.Param.Sum: inj8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) a b -> g a b
+ Data.Comp.Param.Sum: inj9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) a b -> g a b
+ Data.Comp.Param.Sum: inject :: :<: g f => g a (Cxt h f a b) -> Cxt h f a b
+ Data.Comp.Param.Sum: inject10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: inject9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) a (Cxt h g a b) -> Cxt h g a b
+ Data.Comp.Param.Sum: injectConst :: (Difunctor g, :<: g f) => Const g -> Cxt h f Any a
+ Data.Comp.Param.Sum: injectConst2 :: (Difunctor f1, Difunctor f2, Difunctor g, :<: f1 g, :<: f2 g) => Const (f1 :+: f2) -> Cxt h g Any a
+ Data.Comp.Param.Sum: injectConst3 :: (Difunctor f1, Difunctor f2, Difunctor f3, Difunctor g, :<: f1 g, :<: f2 g, :<: f3 g) => Const (f1 :+: (f2 :+: f3)) -> Cxt h g Any a
+ Data.Comp.Param.Sum: injectCxt :: (Difunctor g, :<: g f) => Cxt h g a (Cxt h f a b) -> Cxt h f a b
+ Data.Comp.Param.Sum: instance [incoherent] (Eq (f a b), Eq (g a b)) => Eq ((:+:) f g a b)
+ Data.Comp.Param.Sum: instance [incoherent] (Ord (f a b), Ord (g a b)) => Ord ((:+:) f g a b)
+ Data.Comp.Param.Sum: instance [incoherent] (Show (f a b), Show (g a b)) => Show ((:+:) f g a b)
+ Data.Comp.Param.Sum: liftCxt :: (Difunctor f, :<: g f) => g a b -> Cxt Hole f a b
+ Data.Comp.Param.Sum: proj :: :<: sub sup => sup a b -> Maybe (sub a b)
+ Data.Comp.Param.Sum: proj10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => f a b -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) a b)
+ Data.Comp.Param.Sum: proj2 :: (:<: g1 f, :<: g2 f) => f a b -> Maybe (:+: g2 g1 a b)
+ Data.Comp.Param.Sum: proj3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => f a b -> Maybe (:+: g3 (:+: g2 g1) a b)
+ Data.Comp.Param.Sum: proj4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => f a b -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) a b)
+ Data.Comp.Param.Sum: proj5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => f a b -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) a b)
+ Data.Comp.Param.Sum: proj6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => f a b -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) a b)
+ Data.Comp.Param.Sum: proj7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => f a b -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) a b)
+ Data.Comp.Param.Sum: proj8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => f a b -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) a b)
+ Data.Comp.Param.Sum: proj9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => f a b -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) a b)
+ Data.Comp.Param.Sum: project :: :<: g f => Cxt h f a b -> Maybe (g a (Cxt h f a b))
+ Data.Comp.Param.Sum: project10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => Cxt h f a b -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) a (Cxt h f a b))
+ Data.Comp.Param.Sum: project2 :: (:<: g1 f, :<: g2 f) => Cxt h f a b -> Maybe (:+: g2 g1 a (Cxt h f a b))
+ Data.Comp.Param.Sum: project3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => Cxt h f a b -> Maybe (:+: g3 (:+: g2 g1) a (Cxt h f a b))
+ Data.Comp.Param.Sum: project4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => Cxt h f a b -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) a (Cxt h f a b))
+ Data.Comp.Param.Sum: project5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => Cxt h f a b -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) a (Cxt h f a b))
+ Data.Comp.Param.Sum: project6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => Cxt h f a b -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) a (Cxt h f a b))
+ Data.Comp.Param.Sum: project7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => Cxt h f a b -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) a (Cxt h f a b))
+ Data.Comp.Param.Sum: project8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => Cxt h f a b -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) a (Cxt h f a b))
+ Data.Comp.Param.Sum: project9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => Cxt h f a b -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) a (Cxt h f a b))
+ Data.Comp.Param.Sum: projectConst :: (Difunctor g, :<: g f) => Cxt h f Any a -> Maybe (Const g)
+ Data.Comp.Param.Term: Hole :: b -> Cxt Hole f a b
+ Data.Comp.Param.Term: Place :: a -> Cxt h f a b
+ Data.Comp.Param.Term: Term :: f a (Cxt h f a b) -> Cxt h f a b
+ Data.Comp.Param.Term: coerceCxt :: Cxt h f Any b -> forall a. Cxt h f a b
+ Data.Comp.Param.Term: constTerm :: Difunctor f => Const f -> Term f
+ Data.Comp.Param.Term: data Any
+ Data.Comp.Param.Term: data Cxt :: * -> (* -> * -> *) -> * -> * -> *
+ Data.Comp.Param.Term: data Hole
+ Data.Comp.Param.Term: data NoHole
+ Data.Comp.Param.Term: dimapMCxt :: Ditraversable f m a => (b -> m b') -> Cxt h f a b -> m (Cxt h f a b')
+ Data.Comp.Param.Term: disequenceCxt :: Ditraversable f m a => Cxt h f a (m b) -> m (Cxt h f a b)
+ Data.Comp.Param.Term: fmapCxt :: Difunctor f => (b -> b') -> Cxt h f a b -> Cxt h f a b'
+ Data.Comp.Param.Term: simpCxt :: Difunctor f => f a b -> Cxt Hole f a b
+ Data.Comp.Param.Term: toCxt :: Difunctor f => Trm f a -> Cxt h f a b
+ Data.Comp.Param.Term: type Const f = f Any ()
+ Data.Comp.Param.Term: type Context = Cxt Hole
+ Data.Comp.Param.Term: type Term f = Trm f Any
+ Data.Comp.Param.Term: type Trm f a = Cxt NoHole f a ()
+ Data.Comp.Sum: deepInject10 :: (Functor (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => CxtFun (:+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))))) g
+ Data.Comp.Sum: deepInject4 :: (Functor (:+: f4 (:+: f3 (:+: f2 f1))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => CxtFun (:+: f4 (:+: f3 (:+: f2 f1))) g
+ Data.Comp.Sum: deepInject5 :: (Functor (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => CxtFun (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) g
+ Data.Comp.Sum: deepInject6 :: (Functor (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => CxtFun (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) g
+ Data.Comp.Sum: deepInject7 :: (Functor (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => CxtFun (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) g
+ Data.Comp.Sum: deepInject8 :: (Functor (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => CxtFun (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) g
+ Data.Comp.Sum: deepInject9 :: (Functor (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))), :<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => CxtFun (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) g
+ Data.Comp.Sum: deepProject10 :: (Traversable (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => CxtFunM Maybe f (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))))
+ Data.Comp.Sum: deepProject4 :: (Traversable (:+: g4 (:+: g3 (:+: g2 g1))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => CxtFunM Maybe f (:+: g4 (:+: g3 (:+: g2 g1)))
+ Data.Comp.Sum: deepProject5 :: (Traversable (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => CxtFunM Maybe f (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))
+ Data.Comp.Sum: deepProject6 :: (Traversable (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => CxtFunM Maybe f (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))
+ Data.Comp.Sum: deepProject7 :: (Traversable (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => CxtFunM Maybe f (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))
+ Data.Comp.Sum: deepProject8 :: (Traversable (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => CxtFunM Maybe f (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))
+ Data.Comp.Sum: deepProject9 :: (Traversable (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))), :<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => CxtFunM Maybe f (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))))
+ Data.Comp.Sum: inj10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) a -> g a
+ Data.Comp.Sum: inj4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) a -> g a
+ Data.Comp.Sum: inj5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) a -> g a
+ Data.Comp.Sum: inj6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) a -> g a
+ Data.Comp.Sum: inj7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) a -> g a
+ Data.Comp.Sum: inj8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) a -> g a
+ Data.Comp.Sum: inj9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) a -> g a
+ Data.Comp.Sum: inject10 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g, :<: f10 g) => :+: f10 (:+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))))) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject4 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g) => :+: f4 (:+: f3 (:+: f2 f1)) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject5 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g) => :+: f5 (:+: f4 (:+: f3 (:+: f2 f1))) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject6 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g) => :+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject7 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g) => :+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject8 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g) => :+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1)))))) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject9 :: (:<: f1 g, :<: f2 g, :<: f3 g, :<: f4 g, :<: f5 g, :<: f6 g, :<: f7 g, :<: f8 g, :<: f9 g) => :+: f9 (:+: f8 (:+: f7 (:+: f6 (:+: f5 (:+: f4 (:+: f3 (:+: f2 f1))))))) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: proj10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => f a -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) a)
+ Data.Comp.Sum: proj4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => f a -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) a)
+ Data.Comp.Sum: proj5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => f a -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) a)
+ Data.Comp.Sum: proj6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => f a -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) a)
+ Data.Comp.Sum: proj7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => f a -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) a)
+ Data.Comp.Sum: proj8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => f a -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) a)
+ Data.Comp.Sum: proj9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => f a -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) a)
+ Data.Comp.Sum: project10 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f, :<: g10 f) => Cxt h f a -> Maybe (:+: g10 (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))))) (Cxt h f a))
+ Data.Comp.Sum: project4 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f) => Cxt h f a -> Maybe (:+: g4 (:+: g3 (:+: g2 g1)) (Cxt h f a))
+ Data.Comp.Sum: project5 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f) => Cxt h f a -> Maybe (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))) (Cxt h f a))
+ Data.Comp.Sum: project6 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f) => Cxt h f a -> Maybe (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))) (Cxt h f a))
+ Data.Comp.Sum: project7 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f) => Cxt h f a -> Maybe (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))) (Cxt h f a))
+ Data.Comp.Sum: project8 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f) => Cxt h f a -> Maybe (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1)))))) (Cxt h f a))
+ Data.Comp.Sum: project9 :: (:<: g1 f, :<: g2 f, :<: g3 f, :<: g4 f, :<: g5 f, :<: g6 f, :<: g7 f, :<: g8 f, :<: g9 f) => Cxt h f a -> Maybe (:+: g9 (:+: g8 (:+: g7 (:+: g6 (:+: g5 (:+: g4 (:+: g3 (:+: g2 g1))))))) (Cxt h f a))
+ Data.Comp.Variables: instance [overlap ok] (HasVars f v[a27mn], HasVars g v[a27mn]) => HasVars (f :+: g) v[a27mn]
- Data.Comp.Algebra: appSigFun :: (Functor f, Functor g) => SigFun f g -> CxtFun f g
+ Data.Comp.Algebra: appSigFun :: Functor f => SigFun f g -> CxtFun f g
- Data.Comp.Algebra: appSigFunM :: (Traversable f, Functor g, Monad m) => SigFunM m f g -> CxtFunM m f g
+ Data.Comp.Algebra: appSigFunM :: (Traversable f, Monad m) => SigFunM m f g -> CxtFunM m f g
- Data.Comp.Algebra: appSigFunM' :: (Traversable f, Functor g, Monad m) => SigFunM' m f g -> CxtFunM m f g
+ Data.Comp.Algebra: appSigFunM' :: (Traversable g, Monad m) => SigFunM m f g -> CxtFunM m f g
- Data.Comp.Algebra: appTermHom :: (Traversable f, Functor g) => TermHom f g -> CxtFun f g
+ Data.Comp.Algebra: appTermHom :: (Functor f, Functor g) => TermHom f g -> CxtFun f g
- Data.Comp.Algebra: histo :: (Functor f, DistProd f a f') => CVAlg f a f' -> Term f -> a
+ Data.Comp.Algebra: histo :: (Functor f, DistAnn f a f') => CVAlg f a f' -> Term f -> a
- Data.Comp.Algebra: histoM :: (Traversable f, Monad m, DistProd f a f') => CVAlgM m f a f' -> Term f -> m a
+ Data.Comp.Algebra: histoM :: (Traversable f, Monad m, DistAnn f a f') => CVAlgM m f a f' -> Term f -> m a
- Data.Comp.Algebra: termHomM :: (Functor g, Monad m) => SigFun f g -> TermHomM m f g
+ Data.Comp.Algebra: termHomM :: (Functor g, Monad m) => SigFunM m f g -> TermHomM m f g
- Data.Comp.Multi.Algebra: appSigFun :: (HFunctor f, HFunctor g) => SigFun f g -> CxtFun f g
+ Data.Comp.Multi.Algebra: appSigFun :: HFunctor f => SigFun f g -> CxtFun f g
- Data.Comp.Multi.Algebra: appSigFunM :: (HTraversable f, HFunctor g, Monad m) => SigFunM m f g -> CxtFunM m f g
+ Data.Comp.Multi.Algebra: appSigFunM :: (HTraversable f, Monad m) => SigFunM m f g -> CxtFunM m f g
- Data.Comp.Multi.Algebra: type CxtFun f g = forall a h. Cxt h f a :-> Cxt h g a
+ Data.Comp.Multi.Algebra: type CxtFun f g = forall h. SigFun (Cxt h f) (Cxt h g)
- Data.Comp.Multi.Algebra: type CxtFunM m f g = forall a h. NatM m (Cxt h f a) (Cxt h g a)
+ Data.Comp.Multi.Algebra: type CxtFunM m f g = forall h. SigFunM m (Cxt h f) (Cxt h g)
- Data.Comp.Multi.Sum: deepInject :: (HFunctor g, HFunctor f, :<: g f) => Cxt h g a :-> Cxt h f a
+ Data.Comp.Multi.Sum: deepInject :: (HFunctor g, :<: g f) => CxtFun g f
- Data.Comp.Multi.Sum: deepInject2 :: (HFunctor f1, HFunctor f2, HFunctor g, :<: f1 g, :<: f2 g) => Cxt h (f1 :+: f2) a :-> Cxt h g a
+ Data.Comp.Multi.Sum: deepInject2 :: (HFunctor (:+: f2 f1), :<: f1 g, :<: f2 g) => CxtFun (:+: f2 f1) g
- Data.Comp.Multi.Sum: deepInject3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g, :<: f1 g, :<: f2 g, :<: f3 g) => Cxt h (f1 :+: (f2 :+: f3)) a :-> Cxt h g a
+ Data.Comp.Multi.Sum: deepInject3 :: (HFunctor (:+: f3 (:+: f2 f1)), :<: f1 g, :<: f2 g, :<: f3 g) => CxtFun (:+: f3 (:+: f2 f1)) g
- Data.Comp.Multi.Sum: deepProject :: (HTraversable f, HFunctor g, :<: g f) => NatM Maybe (Cxt h f a) (Cxt h g a)
+ Data.Comp.Multi.Sum: deepProject :: (HTraversable g, :<: g f) => CxtFunM Maybe f g
- Data.Comp.Multi.Sum: deepProject2 :: (HTraversable f, HFunctor g1, HFunctor g2, :<: g1 f, :<: g2 f) => NatM Maybe (Cxt h f a) (Cxt h (g1 :+: g2) a)
+ Data.Comp.Multi.Sum: deepProject2 :: (HTraversable (:+: g2 g1), :<: g1 f, :<: g2 f) => CxtFunM Maybe f (:+: g2 g1)
- Data.Comp.Multi.Sum: deepProject3 :: (HTraversable f, HFunctor g1, HFunctor g2, HFunctor g3, :<: g1 f, :<: g2 f, :<: g3 f) => NatM Maybe (Cxt h f a) (Cxt h (g1 :+: (g2 :+: g3)) a)
+ Data.Comp.Multi.Sum: deepProject3 :: (HTraversable (:+: g3 (:+: g2 g1)), :<: g1 f, :<: g2 f, :<: g3 f) => CxtFunM Maybe f (:+: g3 (:+: g2 g1))
- Data.Comp.Multi.Sum: inj2 :: (:<: f1 g, :<: f2 g) => (f1 :+: f2) a :-> g a
+ Data.Comp.Multi.Sum: inj2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 a i -> g a i
- Data.Comp.Multi.Sum: inj3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => (f1 :+: (f2 :+: f3)) a :-> g a
+ Data.Comp.Multi.Sum: inj3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) a i -> g a i
- Data.Comp.Multi.Sum: inject2 :: (:<: f1 g, :<: f2 g) => (f1 :+: f2) (Cxt h g a) :-> Cxt h g a
+ Data.Comp.Multi.Sum: inject2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 (Cxt h g a) i -> Cxt h g a i
- Data.Comp.Multi.Sum: inject3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => (f1 :+: (f2 :+: f3)) (Cxt h g a) :-> Cxt h g a
+ Data.Comp.Multi.Sum: inject3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) (Cxt h g a) i -> Cxt h g a i
- Data.Comp.Multi.Sum: proj2 :: (:<: g1 f, :<: g2 f) => f a i -> Maybe (((g1 :+: g2) a) i)
+ Data.Comp.Multi.Sum: proj2 :: (:<: g1 f, :<: g2 f) => f a i -> Maybe (:+: g2 g1 a i)
- Data.Comp.Multi.Sum: proj3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => f a i -> Maybe (((g1 :+: (g2 :+: g3)) a) i)
+ Data.Comp.Multi.Sum: proj3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => f a i -> Maybe (:+: g3 (:+: g2 g1) a i)
- Data.Comp.Multi.Sum: project2 :: (:<: g1 f, :<: g2 f) => NatM Maybe (Cxt h f a) ((g1 :+: g2) (Cxt h f a))
+ Data.Comp.Multi.Sum: project2 :: (:<: g1 f, :<: g2 f) => Cxt h f a i -> Maybe (:+: g2 g1 (Cxt h f a) i)
- Data.Comp.Multi.Sum: project3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => NatM Maybe (Cxt h f a) ((g1 :+: (g2 :+: g3)) (Cxt h f a))
+ Data.Comp.Multi.Sum: project3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => Cxt h f a i -> Maybe (:+: g3 (:+: g2 g1) (Cxt h f a) i)
- Data.Comp.Sum: deepInject :: (Functor g, Functor f, :<: g f) => Cxt h g a -> Cxt h f a
+ Data.Comp.Sum: deepInject :: (Functor g, :<: g f) => CxtFun g f
- Data.Comp.Sum: deepInject2 :: (Functor f1, Functor f2, Functor g, :<: f1 g, :<: f2 g) => Cxt h (f1 :+: f2) a -> Cxt h g a
+ Data.Comp.Sum: deepInject2 :: (Functor (:+: f2 f1), :<: f1 g, :<: f2 g) => CxtFun (:+: f2 f1) g
- Data.Comp.Sum: deepInject3 :: (Functor f1, Functor f2, Functor f3, Functor g, :<: f1 g, :<: f2 g, :<: f3 g) => Cxt h (f1 :+: (f2 :+: f3)) a -> Cxt h g a
+ Data.Comp.Sum: deepInject3 :: (Functor (:+: f3 (:+: f2 f1)), :<: f1 g, :<: f2 g, :<: f3 g) => CxtFun (:+: f3 (:+: f2 f1)) g
- Data.Comp.Sum: deepProject :: (Traversable f, Functor g, :<: g f) => Cxt h f a -> Maybe (Cxt h g a)
+ Data.Comp.Sum: deepProject :: (Traversable g, :<: g f) => CxtFunM Maybe f g
- Data.Comp.Sum: deepProject2 :: (Traversable f, Functor g1, Functor g2, :<: g1 f, :<: g2 f) => Cxt h f a -> Maybe (Cxt h (g1 :+: g2) a)
+ Data.Comp.Sum: deepProject2 :: (Traversable (:+: g2 g1), :<: g1 f, :<: g2 f) => CxtFunM Maybe f (:+: g2 g1)
- Data.Comp.Sum: deepProject3 :: (Traversable f, Functor g1, Functor g2, Functor g3, :<: g1 f, :<: g2 f, :<: g3 f) => Cxt h f a -> Maybe (Cxt h (g1 :+: (g2 :+: g3)) a)
+ Data.Comp.Sum: deepProject3 :: (Traversable (:+: g3 (:+: g2 g1)), :<: g1 f, :<: g2 f, :<: g3 f) => CxtFunM Maybe f (:+: g3 (:+: g2 g1))
- Data.Comp.Sum: inj2 :: (:<: f1 g, :<: f2 g) => (f1 :+: f2) a -> g a
+ Data.Comp.Sum: inj2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 a -> g a
- Data.Comp.Sum: inj3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => (f1 :+: (f2 :+: f3)) a -> g a
+ Data.Comp.Sum: inj3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) a -> g a
- Data.Comp.Sum: inject2 :: (:<: f1 g, :<: f2 g) => (f1 :+: f2) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject2 :: (:<: f1 g, :<: f2 g) => :+: f2 f1 (Cxt h g a) -> Cxt h g a
- Data.Comp.Sum: inject3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => (f1 :+: (f2 :+: f3)) (Cxt h g a) -> Cxt h g a
+ Data.Comp.Sum: inject3 :: (:<: f1 g, :<: f2 g, :<: f3 g) => :+: f3 (:+: f2 f1) (Cxt h g a) -> Cxt h g a
- Data.Comp.Sum: proj2 :: (:<: g1 f, :<: g2 f) => f a -> Maybe ((g1 :+: g2) a)
+ Data.Comp.Sum: proj2 :: (:<: g1 f, :<: g2 f) => f a -> Maybe (:+: g2 g1 a)
- Data.Comp.Sum: proj3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => f a -> Maybe ((g1 :+: (g2 :+: g3)) a)
+ Data.Comp.Sum: proj3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => f a -> Maybe (:+: g3 (:+: g2 g1) a)
- Data.Comp.Sum: project2 :: (:<: g1 f, :<: g2 f) => Cxt h f a -> Maybe ((g1 :+: g2) (Cxt h f a))
+ Data.Comp.Sum: project2 :: (:<: g1 f, :<: g2 f) => Cxt h f a -> Maybe (:+: g2 g1 (Cxt h f a))
- Data.Comp.Sum: project3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => Cxt h f a -> Maybe ((g1 :+: (g2 :+: g3)) (Cxt h f a))
+ Data.Comp.Sum: project3 :: (:<: g1 f, :<: g2 f, :<: g3 f) => Cxt h f a -> Maybe (:+: g3 (:+: g2 g1) (Cxt h f a))
Files
- benchmark/Benchmark.hs +70/−31
- benchmark/DataTypes/Comp.hs +5/−37
- benchmark/DataTypes/Standard.hs +0/−53
- benchmark/DataTypes/Transform.hs +5/−15
- benchmark/Functions/Comp/Desugar.hs +10/−7
- benchmark/Functions/Comp/Eval.hs +5/−17
- benchmark/Functions/Comp/Inference.hs +3/−7
- benchmark/Functions/Standard/Desugar.hs +19/−0
- benchmark/Functions/Standard/Eval.hs +0/−38
- benchmark/Multi/DataTypes/Comp.hs +1/−1
- compdata.cabal +163/−33
- examples/Examples/Automata.hs +147/−0
- examples/Examples/DesugarEval.hs +77/−0
- examples/Examples/DesugarPos.hs +72/−0
- examples/Examples/Eval.hs +64/−0
- examples/Examples/EvalM.hs +73/−0
- examples/Examples/GTermHom.hs +230/−0
- examples/Examples/Multi/DesugarEval.hs +88/−0
- examples/Examples/Multi/DesugarPos.hs +75/−0
- examples/Examples/Multi/Eval.hs +69/−0
- examples/Examples/Multi/EvalI.hs +64/−0
- examples/Examples/Multi/EvalM.hs +77/−0
- examples/Examples/MultiParam/DesugarEval.hs +108/−0
- examples/Examples/MultiParam/DesugarPos.hs +75/−0
- examples/Examples/MultiParam/Eval.hs +97/−0
- examples/Examples/MultiParam/EvalAlgM.hs +86/−0
- examples/Examples/MultiParam/EvalI.hs +76/−0
- examples/Examples/MultiParam/EvalM.hs +104/−0
- examples/Examples/MultiParam/FOL.hs +452/−0
- examples/Examples/Param/DesugarEval.hs +115/−0
- examples/Examples/Param/DesugarPos.hs +71/−0
- examples/Examples/Param/Eval.hs +85/−0
- examples/Examples/Param/EvalAlgM.hs +78/−0
- examples/Examples/Param/EvalM.hs +101/−0
- examples/Examples/Param/Parsing.hs +76/−0
- src/Data/Comp.hs +4/−399
- src/Data/Comp/Algebra.hs +440/−48
- src/Data/Comp/Annotation.hs +78/−0
- src/Data/Comp/Arbitrary.hs +2/−4
- src/Data/Comp/Automata.hs +0/−147
- src/Data/Comp/DeepSeq.hs +2/−7
- src/Data/Comp/Derive.hs +15/−44
- src/Data/Comp/Derive/Arbitrary.hs +8/−8
- src/Data/Comp/Derive/DeepSeq.hs +3/−3
- src/Data/Comp/Derive/Equality.hs +3/−3
- src/Data/Comp/Derive/Foldable.hs +3/−3
- src/Data/Comp/Derive/Injections.hs +82/−0
- src/Data/Comp/Derive/LiftSum.hs +54/−0
- src/Data/Comp/Derive/Multi/Equality.hs +0/−81
- src/Data/Comp/Derive/Multi/Foldable.hs +0/−119
- src/Data/Comp/Derive/Multi/Functor.hs +0/−63
- src/Data/Comp/Derive/Multi/Show.hs +0/−69
- src/Data/Comp/Derive/Multi/SmartConstructors.hs +0/−61
- src/Data/Comp/Derive/Multi/Traversable.hs +0/−83
- src/Data/Comp/Derive/Ordering.hs +3/−3
- src/Data/Comp/Derive/Projections.hs +95/−0
- src/Data/Comp/Derive/Show.hs +3/−3
- src/Data/Comp/Derive/SmartAConstructors.hs +47/−0
- src/Data/Comp/Derive/SmartConstructors.hs +3/−5
- src/Data/Comp/Derive/Traversable.hs +3/−3
- src/Data/Comp/Derive/Utils.hs +9/−0
- src/Data/Comp/Desugar.hs +42/−0
- src/Data/Comp/Equality.hs +2/−1
- src/Data/Comp/Multi.hs +132/−160
- src/Data/Comp/Multi/Algebra.hs +77/−63
- src/Data/Comp/Multi/Annotation.hs +77/−0
- src/Data/Comp/Multi/Derive.hs +48/−0
- src/Data/Comp/Multi/Derive/Equality.hs +81/−0
- src/Data/Comp/Multi/Derive/Foldable.hs +119/−0
- src/Data/Comp/Multi/Derive/Functor.hs +63/−0
- src/Data/Comp/Multi/Derive/Injections.hs +87/−0
- src/Data/Comp/Multi/Derive/LiftSum.hs +56/−0
- src/Data/Comp/Multi/Derive/Projections.hs +100/−0
- src/Data/Comp/Multi/Derive/Show.hs +69/−0
- src/Data/Comp/Multi/Derive/SmartAConstructors.hs +47/−0
- src/Data/Comp/Multi/Derive/SmartConstructors.hs +69/−0
- src/Data/Comp/Multi/Derive/Traversable.hs +83/−0
- src/Data/Comp/Multi/Desugar.hs +41/−0
- src/Data/Comp/Multi/Equality.hs +2/−1
- src/Data/Comp/Multi/Generic.hs +85/−0
- src/Data/Comp/Multi/Ops.hs +20/−22
- src/Data/Comp/Multi/Product.hs +0/−87
- src/Data/Comp/Multi/Show.hs +5/−7
- src/Data/Comp/Multi/Sum.hs +89/−79
- src/Data/Comp/Multi/Term.hs +41/−0
- src/Data/Comp/Multi/Variables.hs +9/−13
- src/Data/Comp/MultiParam.hs +34/−0
- src/Data/Comp/MultiParam/Algebra.hs +339/−0
- src/Data/Comp/MultiParam/Annotation.hs +82/−0
- src/Data/Comp/MultiParam/Any.hs +23/−0
- src/Data/Comp/MultiParam/Derive.hs +51/−0
- src/Data/Comp/MultiParam/Derive/Equality.hs +79/−0
- src/Data/Comp/MultiParam/Derive/HDifunctor.hs +85/−0
- src/Data/Comp/MultiParam/Derive/Injections.hs +91/−0
- src/Data/Comp/MultiParam/Derive/LiftSum.hs +56/−0
- src/Data/Comp/MultiParam/Derive/Ordering.hs +93/−0
- src/Data/Comp/MultiParam/Derive/Projections.hs +107/−0
- src/Data/Comp/MultiParam/Derive/Show.hs +84/−0
- src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs +47/−0
- src/Data/Comp/MultiParam/Derive/SmartConstructors.hs +70/−0
- src/Data/Comp/MultiParam/Desugar.hs +41/−0
- src/Data/Comp/MultiParam/Equality.hs +64/−0
- src/Data/Comp/MultiParam/FreshM.hs +64/−0
- src/Data/Comp/MultiParam/HDifunctor.hs +74/−0
- src/Data/Comp/MultiParam/HDitraversable.hs +62/−0
- src/Data/Comp/MultiParam/Ops.hs +120/−0
- src/Data/Comp/MultiParam/Ordering.hs +67/−0
- src/Data/Comp/MultiParam/Show.hs +51/−0
- src/Data/Comp/MultiParam/Sum.hs +291/−0
- src/Data/Comp/MultiParam/Term.hs +120/−0
- src/Data/Comp/Ops.hs +23/−25
- src/Data/Comp/Ordering.hs +2/−2
- src/Data/Comp/Param.hs +32/−0
- src/Data/Comp/Param/Algebra.hs +930/−0
- src/Data/Comp/Param/Annotation.hs +80/−0
- src/Data/Comp/Param/Any.hs +23/−0
- src/Data/Comp/Param/Derive.hs +48/−0
- src/Data/Comp/Param/Derive/Difunctor.hs +96/−0
- src/Data/Comp/Param/Derive/Ditraversable.hs +95/−0
- src/Data/Comp/Param/Derive/Equality.hs +84/−0
- src/Data/Comp/Param/Derive/Injections.hs +86/−0
- src/Data/Comp/Param/Derive/LiftSum.hs +54/−0
- src/Data/Comp/Param/Derive/Ordering.hs +98/−0
- src/Data/Comp/Param/Derive/Projections.hs +101/−0
- src/Data/Comp/Param/Derive/Show.hs +90/−0
- src/Data/Comp/Param/Derive/SmartAConstructors.hs +47/−0
- src/Data/Comp/Param/Derive/SmartConstructors.hs +61/−0
- src/Data/Comp/Param/Desugar.hs +42/−0
- src/Data/Comp/Param/Difunctor.hs +32/−0
- src/Data/Comp/Param/Ditraversable.hs +127/−0
- src/Data/Comp/Param/Equality.hs +61/−0
- src/Data/Comp/Param/FreshM.hs +51/−0
- src/Data/Comp/Param/Ops.hs +121/−0
- src/Data/Comp/Param/Ordering.hs +64/−0
- src/Data/Comp/Param/Show.hs +49/−0
- src/Data/Comp/Param/Sum.hs +199/−0
- src/Data/Comp/Param/Term.hs +121/−0
- src/Data/Comp/Product.hs +0/−75
- src/Data/Comp/Show.hs +3/−7
- src/Data/Comp/Sum.hs +91/−108
- src/Data/Comp/Term.hs +18/−14
- src/Data/Comp/Variables.hs +7/−10
- testsuite/tests/Data/Comp/Examples/Comp.hs +56/−0
- testsuite/tests/Data/Comp/Examples/Multi.hs +59/−0
- testsuite/tests/Data/Comp/Examples/MultiParam.hs +52/−0
- testsuite/tests/Data/Comp/Examples/Param.hs +58/−0
- testsuite/tests/Data/Comp/Examples_Test.hs +19/−0
- testsuite/tests/Data/Comp_Test.hs +3/−2
- testsuite/tests/Test/Utils.hs +1/−1
benchmark/Benchmark.hs view
@@ -42,42 +42,81 @@ 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 [- -- bench "Comp.desug" (nf A.desugExpr aExpr),- -- bench "Comp.desugAlg" (nf A.desugExpr2 aExpr),- -- bench "Standard.desug" (nf S.desug sExpr),+ where getBench (sExpr, aExpr,n) = bgroup n paperBenchmarks+ -- these are the benchmarks from the WGP '11 paper+ paperBenchmarks = [+ bench "desugHom" (nf A.desugExpr aExpr),+ bench "desugCata" (nf A.desugExpr2 aExpr),+ bench "desug[Hom,Cata] (comparison)" (nf S.desug sExpr),+ bench "inferDesug" (nf A.desugType2 aExpr),+ bench "inferDesug (fusion)" (nf A.desugType2' aExpr),+ bench "inferDesug (comparison)" (nf S.desugType2 sExpr),+ bench "inferDesugM" (nf A.desugType aExpr),+ bench "inferDesugM (fusion)" (nf A.desugType' aExpr),+ bench "inferDesugM (comparison)" (nf S.desugType sExpr),+ bench "infer" (nf A.typeSugar2 aExpr),+ bench "infer (comparison)" (nf S.typeSugar2 sExpr),+ bench "inferM" (nf A.typeSugar aExpr),+ bench "inferM (comparison)" (nf S.typeSugar sExpr),+ bench "evalDesug" (nf A.desugEval2 aExpr),+ bench "evalDesug (fusion)" (nf A.desugEval2' aExpr),+ bench "evalDesug (comparison)" (nf S.desugEval2 sExpr),+ bench "evalDesugM" (nf A.desugEval aExpr),+ bench "evalDesugM (fusion)" (nf A.desugEval' aExpr),+ bench "evalDesugM (comparison)" (nf S.desugEval sExpr),+ bench "eval" (nf A.evalSugar2 aExpr),+ bench "evalDirect" (nf A.evalDirectE2 aExpr),+ bench "eval[Direct] (comparison)" (nf S.evalSugar2 sExpr),+ bench "evalM" (nf A.evalSugar aExpr),+ bench "evalDirectM" (nf A.evalDirectE aExpr),+ bench "eval[Direct]M (comparison)" (nf S.evalSugar sExpr),+ bench "contVar" (nf (A.contVar' 10) aExpr),+ bench "contVar (comparison)" (nf (S.contVar 10) sExpr),+ bench "contVarG" (nf (A.contVarGen 10) aExpr),+ bench "contVarU" (nf (S.contVarGen 10) sExpr),+ bench "freeVars[GU]" (nf A.freeVars' aExpr),+ bench "freeVarsG" (nf A.freeVarsGen aExpr),+ bench "freeVarsU" (nf S.freeVarsGen sExpr),+ bench "freeVars[GU] (comparison)" (nf S.freeVars sExpr)]+ -- these are all the benchmarks+ allBenchmarks = [+ bench "Comp.desug" (nf A.desugExpr aExpr),+ bench "Comp.desug'" (nf A.desugExpr' aExpr),+ bench "Comp.desugAlg" (nf A.desugExpr2 aExpr),+ bench "Standard.desug" (nf S.desug sExpr),+ bench "Standard.desug'" (nf S.desug' sExpr), bench "Comp.desugType" (nf A.desugType aExpr), bench "Comp.desugType'" (nf A.desugType' aExpr), bench "Standard.desugType" (nf S.desugType sExpr),- -- bench "Comp.typeSugar" (nf A.typeSugar aExpr),- -- bench "Standard.typeSugar" (nf S.typeSugar sExpr),+ bench "Comp.typeSugar" (nf A.typeSugar aExpr),+ bench "Standard.typeSugar" (nf S.typeSugar sExpr), bench "Comp.desugType2" (nf A.desugType2 aExpr), bench "Comp.desugType2'" (nf A.desugType2' aExpr),- bench "Standard.desugType2" (nf S.desugType2 sExpr)- -- bench "Comp.typeSugar2" (nf A.typeSugar2 aExpr),- -- bench "Standard.typeSugar2" (nf S.typeSugar2 sExpr),- -- bench "Comp.desugEval" (nf A.desugEval aExpr),- -- bench "Comp.desugEval'" (nf A.desugEval' aExpr),- -- bench "Standard.desugEval" (nf S.desugEval sExpr),- -- bench "Comp.evalSugar" (nf A.evalSugar aExpr),- -- bench "Comp.evalDirect" (nf A.evalDirectE aExpr),- -- bench "Standard.evalSugar" (nf S.evalSugar sExpr),- -- bench "Comp.desugEval2" (nf A.desugEval2 aExpr),- -- bench "Comp.desugEval2'" (nf A.desugEval2' aExpr),- -- bench "Standard.desugEval2" (nf S.desugEval2 sExpr),- -- bench "Comp.evalSugar2" (nf A.evalSugar2 aExpr),- -- bench "Comp.evalDirect2" (nf A.evalDirectE2 aExpr),- -- bench "Standard.evalSugar2" (nf S.evalSugar2 sExpr),- -- bench "Comp.contVar" (nf (A.contVar 10) aExpr),- -- bench "Comp.contVar'" (nf (A.contVar' 10) aExpr),- -- bench "Comp.contVarGen" (nf (A.contVarGen 10) aExpr),- -- bench "Standard.contVar" (nf (S.contVar 10) sExpr),- -- bench "Standard.contVarGen" (nf (S.contVarGen 10) sExpr),- -- bench "Comp.freeVars" (nf A.freeVars aExpr),- -- bench "Comp.freeVars'" (nf A.freeVars' aExpr),- -- bench "Comp.freeVarsGen" (nf A.freeVarsGen aExpr),- -- bench "Standard.freeVars" (nf S.freeVars sExpr),- -- bench "Standard.freeVarsGen" (nf S.freeVarsGen sExpr)+ bench "Standard.desugType2" (nf S.desugType2 sExpr),+ bench "Comp.typeSugar2" (nf A.typeSugar2 aExpr),+ bench "Standard.typeSugar2" (nf S.typeSugar2 sExpr),+ bench "Comp.desugEval" (nf A.desugEval aExpr),+ bench "Comp.desugEval'" (nf A.desugEval' aExpr),+ bench "Standard.desugEval" (nf S.desugEval sExpr),+ bench "Comp.evalSugar" (nf A.evalSugar aExpr),+ bench "Comp.evalDirect" (nf A.evalDirectE aExpr),+ bench "Standard.evalSugar" (nf S.evalSugar sExpr),+ bench "Comp.desugEval2" (nf A.desugEval2 aExpr),+ bench "Comp.desugEval2'" (nf A.desugEval2' aExpr),+ bench "Standard.desugEval2" (nf S.desugEval2 sExpr),+ bench "Comp.evalSugar2" (nf A.evalSugar2 aExpr),+ bench "Comp.evalDirect2" (nf A.evalDirectE2 aExpr),+ bench "Standard.evalSugar2" (nf S.evalSugar2 sExpr),+ bench "Comp.contVar" (nf (A.contVar 10) aExpr),+ bench "Comp.contVar'" (nf (A.contVar' 10) aExpr),+ bench "Comp.contVarGen" (nf (A.contVarGen 10) aExpr),+ bench "Standard.contVar" (nf (S.contVar 10) sExpr),+ bench "Standard.contVarGen" (nf (S.contVarGen 10) sExpr),+ bench "Comp.freeVars" (nf A.freeVars aExpr),+ bench "Comp.freeVars'" (nf A.freeVars' aExpr),+ bench "Comp.freeVarsGen" (nf A.freeVarsGen aExpr),+ bench "Standard.freeVars" (nf S.freeVars sExpr),+ bench "Standard.freeVarsGen" (nf S.freeVarsGen sExpr) ] randStdBenchmarks :: Int -> IO Benchmark
benchmark/DataTypes/Comp.hs view
@@ -17,6 +17,7 @@ import DataTypes import Data.Comp.Derive import Data.Comp+import Data.Comp.Ops import Data.Comp.Arbitrary () import Data.Comp.Show import Data.Traversable@@ -38,13 +39,6 @@ type BaseTypeSig = ValueT type BaseType = Term BaseTypeSig -type HOASValueSig = Value :+: Lam-type HOASValueExpr = Term HOASValueSig-type HOASExprSig = Value :+: Lam :+: App :+: Op-type HOASExpr = Term HOASExprSig-type HOASBaseTypeSig = ValueT :+: FunT-type HOASBaseType = Term HOASBaseTypeSig- data ValueT e = TInt | TBool | TPair e e@@ -75,28 +69,12 @@ | Impl e e deriving (Eq, Functor) -data FunT e = TFun e e- deriving (Eq, Functor)--data Lam e = Lam (e -> e)--data App e = App e e- deriving (Eq, Functor)--$(derive [instanceNFData, instanceArbitrary] [''Proj])+$(derive [makeNFData, makeArbitrary] [''Proj]) $(derive- [instanceFoldable, instanceTraversable,- instanceEqF, instanceNFDataF, instanceArbitraryF, smartConstructors]- [''Value, ''Op, ''Sugar, ''ValueT, ''FunT, ''App])--$(derive [smartConstructors] [''Lam])--instance EqF Lam where- eqF _ _ = False--instance NFDataF Lam where- rnfF (Lam f) = f `seq` ()+ [makeFoldable, makeTraversable,+ makeEqF, makeNFDataF, makeArbitraryF, smartConstructors]+ [''Value, ''Op, ''Sugar, ''ValueT]) showBinOp :: String -> String -> String -> String showBinOp op x y = "("++ x ++ op ++ y ++ ")"@@ -129,16 +107,6 @@ showF (Gt x y) = "(" ++ x ++ ">" ++ y ++ ")" showF (Or x y) = "(" ++ x ++ "||" ++ y ++ ")" showF (Impl x y) = "(" ++ x ++ "->" ++ y ++ ")"--instance ShowF Lam where - showF (Lam f) = "\\x. " ++ f "x"--instance ShowF App where - showF (App x y) = x ++ " " ++ y--instance ShowF FunT where - showF (TFun x y) = x ++ " -> " ++ y- class GenTyped f where genTypedAlg :: CoalgM Gen f BaseType
benchmark/DataTypes/Standard.hs view
@@ -62,58 +62,6 @@ | VHTFun VType VType deriving (Eq,Typeable,Data) --- HOAS-data HOASExpr = HOASInt Int- | HOASBool Bool- | HOASPair HOASExpr HOASExpr- | HOASPlus HOASExpr HOASExpr- | HOASMult HOASExpr HOASExpr- | HOASIf HOASExpr HOASExpr HOASExpr- | HOASEq HOASExpr HOASExpr- | HOASLt HOASExpr HOASExpr- | HOASAnd HOASExpr HOASExpr- | HOASNot HOASExpr- | HOASProj SProj HOASExpr- | HOASApp HOASExpr HOASExpr- | HOASLam (HOASSExpr -> HOASExpr) -- Nasty dependency with HOASSExpr!- | HOASVal HOASSExpr -- Nasty dependency with HOASSExpr!- deriving (Typeable,Data)--data HOASSExpr = HOASSInt Int- | HOASSBool Bool- | HOASSPair HOASSExpr HOASSExpr- | HOASSLam (HOASSExpr -> HOASSExpr)- deriving (Typeable,Data)--instance NFData HOASExpr where- rnf (HOASInt n) = rnf n `seq` ()- rnf (HOASBool b) = rnf b `seq` ()- rnf (HOASPair e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASPlus e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASMult e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASIf e1 e2 e3) = rnf e1 `seq` rnf e2 `seq` rnf e3 `seq` ()- rnf (HOASEq e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASLt e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASAnd e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASNot e) = rnf e `seq` ()- rnf (HOASProj e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASApp e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASLam e) = e `seq` ()- rnf (HOASVal e) = rnf e `seq` ()--instance NFData HOASSExpr where- rnf (HOASSInt n) = rnf n `seq` ()- rnf (HOASSBool b) = rnf b `seq` ()- rnf (HOASSPair e1 e2) = rnf e1 `seq` rnf e2 `seq` ()- rnf (HOASSLam e) = e `seq` ()--instance Eq HOASSExpr where- (==) (HOASSInt n1) (HOASSInt n2) = n1 == n2- (==) (HOASSBool b1) (HOASSBool b2) = b1 == b2- (==) (HOASSPair e1 e2) (HOASSPair e3 e4) = e1 == e3 && e2 == e4- (==) _ _ = False-- showBinOp :: String -> String -> String -> String showBinOp op x y = "("++ x ++ op ++ y ++ ")" @@ -122,7 +70,6 @@ show (SBool b) = show b show (SPair x y) = showBinOp "," (show x) (show y) - instance Show OExpr where show (OInt i) = show i show (OBool b) = show b
benchmark/DataTypes/Transform.hs view
@@ -11,6 +11,7 @@ module DataTypes.Transform where import Data.Comp+import Data.Comp.Derive import DataTypes.Standard as S import DataTypes.Comp @@ -20,9 +21,7 @@ transSugar :: (Functor f, TransSugar f) => Term f -> PExpr transSugar = cata transSugarAlg -instance (TransSugar f, TransSugar g) => TransSugar (f :+: g) where- transSugarAlg (Inl v) = transSugarAlg v- transSugarAlg (Inr v) = transSugarAlg v+$(derive [liftSum] [''TransSugar]) instance TransSugar Value where transSugarAlg (VInt i) = PInt i@@ -56,10 +55,7 @@ transCore :: (Functor f, TransCore f) => Term f -> OExpr transCore = cata transCoreAlg --instance (TransCore f, TransCore g) => TransCore (f :+: g) where- transCoreAlg (Inl v) = transCoreAlg v- transCoreAlg (Inr v) = transCoreAlg v+$(derive [liftSum] [''TransCore]) instance TransCore Value where transCoreAlg (VInt i) = OInt i@@ -84,10 +80,7 @@ transVal :: (Functor f, TransVal f) => Term f -> SExpr transVal = cata transValAlg --instance (TransVal f, TransVal g) => TransVal (f :+: g) where- transValAlg (Inl v) = transValAlg v- transValAlg (Inr v) = transValAlg v+$(derive [liftSum] [''TransVal]) instance TransVal Value where transValAlg (VInt i) = SInt i@@ -100,10 +93,7 @@ transType :: (Functor f, TransType f) => Term f -> VType transType = cata transTypeAlg --instance (TransType f, TransType g) => TransType (f :+: g) where- transTypeAlg (Inl v) = transTypeAlg v- transTypeAlg (Inr v) = transTypeAlg v+$(derive [liftSum] [''TransType]) instance TransType ValueT where transTypeAlg TInt = VTInt
benchmark/Functions/Comp/Desugar.hs view
@@ -12,7 +12,7 @@ import DataTypes.Comp import Data.Comp-import Data.Traversable+import Data.Comp.Derive -- de-sugar @@ -22,14 +22,19 @@ desugExpr :: SugarExpr -> Expr desugExpr = desug +desugExpr' :: SugarExpr -> Expr+desugExpr' = desug'+ desug :: Desug f e => Term f -> Term e {-# INLINE desug #-} desug = appTermHom desugAlg -instance (Desug f e, Desug g e) => Desug (g :+: f) e where- desugAlg (Inl v) = desugAlg v- desugAlg (Inr v) = desugAlg v+desug' :: Desug f e => Term f -> Term e+{-# INLINE desug' #-}+desug' = appTermHom' desugAlg +$(derive [liftSum] [''Desug])+ instance (Value :<: v, Functor v) => Desug Value v where desugAlg = liftCxt @@ -55,9 +60,7 @@ desug2 :: (Functor f, Desug2 f g) => Term f -> Term g desug2 = cata desugAlg2 -instance (Desug2 f e, Desug2 g e) => Desug2 (f :+: g) e where- desugAlg2 (Inl v) = desugAlg2 v- desugAlg2 (Inr v) = desugAlg2 v+$(derive [liftSum] [''Desug2]) instance (Value :<: v) => Desug2 Value v where desugAlg2 = inject
benchmark/Functions/Comp/Eval.hs view
@@ -13,6 +13,7 @@ import DataTypes.Comp import Functions.Comp.Desugar import Data.Comp+import Data.Comp.Derive import Control.Monad import Data.Traversable @@ -24,9 +25,7 @@ eval :: (Traversable e, Eval e v m) => Term e -> m (Term v) eval = cataM evalAlg -instance (Eval f v m, Eval g v m) => Eval (f :+: g) v m where- evalAlg (Inl v) = evalAlg v- evalAlg (Inr v) = evalAlg v+$(derive [liftSum] [''Eval]) instance (Value :<: v, Monad m) => Eval Value v m where evalAlg = return . inject@@ -79,9 +78,7 @@ evalDirectE :: SugarExpr -> Err ValueExpr evalDirectE = evalDirect -instance (EvalDir f m, EvalDir g m) => EvalDir (f :+: g) m where- evalDir (Inl v) = evalDir v- evalDir (Inr v) = evalDir v+$(derive [liftSum] [''EvalDir]) instance (Monad m) => EvalDir Value m where evalDir (VInt i) = return $ iVInt i@@ -141,9 +138,7 @@ eval2 :: (Functor e, Eval2 e v) => Term e -> Term v eval2 = cata eval2Alg -instance (Eval2 f v, Eval2 g v) => Eval2 (f :+: g) v where- eval2Alg (Inl v) = eval2Alg v- eval2Alg (Inr v) = eval2Alg v+$(derive [liftSum] [''Eval2]) instance (Value :<: v) => Eval2 Value v where eval2Alg = inject@@ -163,11 +158,6 @@ Just (VPair x y) -> (x,y) _ -> undefined -coerceLam2 :: (Lam :<: v) => Term v -> Term v -> Term v-coerceLam2 t = case project t of- Just (Lam f) -> f- _ -> undefined- instance (Value :<: v, EqF v) => Eval2 Op v where eval2Alg (Plus x y) = (\ i j -> iVInt (i + j)) (coerceInt2 x) (coerceInt2 y) eval2Alg (Mult x y) = (\ i j -> iVInt (i * j)) (coerceInt2 x) (coerceInt2 y)@@ -202,9 +192,7 @@ evalDirectE2 :: SugarExpr -> ValueExpr evalDirectE2 = evalDirect2 -instance (EvalDir2 f, EvalDir2 g) => EvalDir2 (f :+: g) where- evalDir2 (Inl v) = evalDir2 v- evalDir2 (Inr v) = evalDir2 v+$(derive [liftSum] [''EvalDir2]) instance EvalDir2 Value where evalDir2 (VInt i) = iVInt i
benchmark/Functions/Comp/Inference.hs view
@@ -13,7 +13,7 @@ import Functions.Comp.Desugar import DataTypes.Comp import Data.Comp-import Data.Traversable+import Data.Comp.Derive -- type inference @@ -26,9 +26,7 @@ inferBaseType :: (Traversable f, InferType f ValueT m) => Term f -> m BaseType inferBaseType = inferType -instance (InferType f t m, InferType g t m) => InferType (f :+: g) t m where- inferTypeAlg (Inl v) = inferTypeAlg v- inferTypeAlg (Inr v) = inferTypeAlg v+$(derive [liftSum] [''InferType]) instance (ValueT :<: t, Monad m) => InferType Value t m where inferTypeAlg (VInt _) = return $ inject TInt@@ -89,9 +87,7 @@ inferBaseType2 :: (Functor f, InferType2 f ValueT) => Term f -> BaseType inferBaseType2 = inferType2 -instance (InferType2 f t, InferType2 g t) => InferType2 (f :+: g) t where- inferTypeAlg2 (Inl v) = inferTypeAlg2 v- inferTypeAlg2 (Inr v) = inferTypeAlg2 v+$(derive [liftSum] [''InferType2]) instance (ValueT :<: t) => InferType2 Value t where inferTypeAlg2 (VInt _) = inject TInt
benchmark/Functions/Standard/Desugar.hs view
@@ -21,3 +21,22 @@ desug (PGt x y) = (desug y) `OLt` (desug x) desug (POr x y) = ONot (ONot (desug x) `OAnd` ONot (desug y)) desug (PImpl x y) = ONot ((desug x) `OAnd` ONot (desug y))+++desug' :: PExpr -> PExpr+desug' e@(PInt _) = e+desug' e@(PBool _) = e+desug' (PPair x y) = PPair (desug' x) (desug' y)+desug' (PPlus x y) = PPlus (desug' x) (desug' y)+desug' (PMult x y) = PMult (desug' x) (desug' y)+desug' (PIf b x y) = PIf (desug' b) (desug' x) (desug' y)+desug' (PEq x y) = PEq (desug' x) (desug' y)+desug' (PLt x y) = PLt (desug' x) (desug' y)+desug' (PAnd x y) = PAnd (desug' x) (desug' y)+desug' (PNot x) = PNot (desug' x)+desug' (PProj p x) = PProj p (desug' x)+desug' (PNeg x) = PInt (-1) `PMult` (desug' x)+desug' (PMinus x y) = (desug' x) `PPlus` ((PInt (-1)) `PMult` (desug' y))+desug' (PGt x y) = (desug' y) `PLt` (desug' x)+desug' (POr x y) = PNot (PNot (desug' x) `PAnd` PNot (desug' y))+desug' (PImpl x y) = PNot ((desug' x) `PAnd` PNot (desug' y))
benchmark/Functions/Standard/Eval.hs view
@@ -109,41 +109,3 @@ desugEval2 :: PExpr -> SExpr desugEval2 = eval2 . desug-----coerceHOASInt2 :: HOASSExpr -> Int-coerceHOASInt2 (HOASSInt i) = i-coerceHOASInt2 _ = undefined--coerceHOASBool2 :: HOASSExpr -> Bool-coerceHOASBool2 (HOASSBool b) = b-coerceHOASBool2 _ = undefined--coerceHOASPair2 :: HOASSExpr -> (HOASSExpr,HOASSExpr)-coerceHOASPair2 (HOASSPair x y) = (x,y)-coerceHOASPair2 _ = undefined--coerceHOASLam2 :: HOASSExpr -> HOASSExpr -> HOASSExpr-coerceHOASLam2 (HOASSLam f) = f-coerceHOASLam2 _ = undefined--evalHOAS :: HOASExpr -> HOASSExpr-evalHOAS (HOASInt i) = HOASSInt i-evalHOAS (HOASBool b) = HOASSBool b-evalHOAS (HOASPair x y) = HOASSPair (evalHOAS x) (evalHOAS y)-evalHOAS (HOASPlus x y) = (\ x y -> HOASSInt (x + y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)-evalHOAS (HOASMult x y) = (\ x y -> HOASSInt (x * y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)-evalHOAS (HOASIf b x y) = if coerceHOASBool2 $ evalHOAS b then evalHOAS x else evalHOAS y-evalHOAS (HOASEq x y) = (\ x y -> HOASSBool (x == y)) (evalHOAS x) (evalHOAS y)-evalHOAS (HOASLt x y) = (\ x y -> HOASSBool (x < y)) (coerceHOASInt2 $ evalHOAS x) (coerceHOASInt2 $ evalHOAS y)-evalHOAS (HOASAnd x y) =(\ x y -> HOASSBool (x && y)) (coerceHOASBool2 $ evalHOAS x) (coerceHOASBool2 $ evalHOAS y)-evalHOAS (HOASNot x) = (HOASSBool . not)(coerceHOASBool2 $ evalHOAS x)-evalHOAS (HOASProj p x) = select (coerceHOASPair2 $ evalHOAS x)- where select (x,y) = case p of- SProjLeft -> x- SProjRight -> y-evalHOAS (HOASApp x y) = (coerceHOASLam2 $ evalHOAS x) (evalHOAS y)-evalHOAS (HOASLam f) = HOASSLam $ evalHOAS . f-evalHOAS (HOASVal v) = v
benchmark/Multi/DataTypes/Comp.hs view
@@ -50,7 +50,7 @@ Impl :: e Bool -> e Bool -> Sugar e Bool $(derive- [instanceHFunctor, instanceHFoldable, instanceHTraversable, instanceHEqF, smartHConstructors]+ [makeHFunctor, makeHFoldable, makeHTraversable, makeHEqF, smartHConstructors] [''ValueT, ''Value, ''Op, ''Sugar])
compdata.cabal view
@@ -1,5 +1,5 @@ Name: compdata-Version: 0.2+Version: 0.3 Synopsis: Compositional Data Types Description: @@ -16,7 +16,7 @@ well by leveraging Haskell's type class machinery. . Building on that foundation, this library provides additional- extensions and (run-time) optimisations which makes compositional data types+ extensions and (run-time) optimisations which make compositional data types usable for practical implementations. In particular, it provides an excellent framework for manipulating and analysing abstract syntax trees in a type-safe manner. Thus, it is perfectly@@ -28,7 +28,7 @@ * Compositional data types in the style of Wouter Swierstra's Functional Pearl /Data types à la carte/. .- * Modular definition of function on compositional data types through+ * Modular definition of functions on compositional data types through catamorphisms and anamorphisms as well as more structured recursion schemes such as primitive recursion and co-recursion, and course-of-value iteration and co-iteration.@@ -61,12 +61,25 @@ also /smart constructors/, which allow to easily construct inhabitants of compositional data types, are automatically generated. .- * /Mutually recursive data types/. All of the above is also lifted to- families of mutually recursive data types.+ * /Mutually recursive data types/ and+ /generalised algebraic data types (GADTs)/. All of the above is also lifted+ to families of mutually recursive data types and (more generally) GADTs.+ This extension resides in the module "Data.Comp.Multi". .- For examples illustrating the use of compositional data types, consult- "Data.Comp" resp. "Data.Comp.Multi" for mutually recursive data types.+ * /Parametric compositional data types/. 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".+ .+ * /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".+ . + Examples of using (generalised) (parametric) compositional data types are+ bundled with the package in the libray @examples@.+ Category: Generics License: BSD3 License-file: LICENSE@@ -80,6 +93,11 @@ testsuite/tests/Data_Test.hs, testsuite/tests/Data/Comp_Test.hs, testsuite/tests/Data/Comp/Equality_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/Test/Utils.hs -- benchmark files benchmark/Test.hs@@ -103,7 +121,31 @@ benchmark/Functions/Standard/FreeVars.hs benchmark/Functions/Standard/Inference.hs benchmark/Functions/Standard.hs-+ -- example files+ examples/Examples/GTermHom.hs+ examples/Examples/Eval.hs+ examples/Examples/EvalM.hs+ examples/Examples/DesugarEval.hs+ examples/Examples/DesugarPos.hs+ examples/Examples/Automata.hs,+ examples/Examples/Multi/Eval.hs+ examples/Examples/Multi/EvalI.hs+ examples/Examples/Multi/EvalM.hs+ examples/Examples/Multi/DesugarEval.hs+ examples/Examples/Multi/DesugarPos.hs+ examples/Examples/Param/Eval.hs+ examples/Examples/Param/EvalM.hs+ examples/Examples/Param/EvalAlgM.hs+ examples/Examples/Param/DesugarEval.hs+ examples/Examples/Param/DesugarPos.hs+ examples/Examples/Param/Parsing.hs+ examples/Examples/MultiParam/Eval.hs+ examples/Examples/MultiParam/EvalI.hs+ examples/Examples/MultiParam/EvalM.hs+ examples/Examples/MultiParam/EvalAlgM.hs+ examples/Examples/MultiParam/DesugarEval.hs+ examples/Examples/MultiParam/DesugarPos.hs+ examples/Examples/MultiParam/FOL.hs flag test description: Build test executable.@@ -115,49 +157,137 @@ library- Exposed-Modules: Data.Comp, Data.Comp.Product, 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.Automata,- Data.Comp.Arbitrary, Data.Comp.Show, Data.Comp.Variables,- Data.Comp.Decompose, Data.Comp.Unification,- Data.Comp.Derive, Data.Comp.Matching, Data.Comp.Multi,- Data.Comp.Multi.Term, Data.Comp.Multi.Sum,+ 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.Multi,+ Data.Comp.Multi.Term,+ Data.Comp.Multi.Sum, Data.Comp.Multi.Functor,- Data.Comp.Multi.Foldable, Data.Comp.Multi.Traversable,+ Data.Comp.Multi.Foldable,+ Data.Comp.Multi.Traversable, Data.Comp.Multi.Algebra,- Data.Comp.Multi.Product, Data.Comp.Multi.Show,- Data.Comp.Multi.Equality, Data.Comp.Multi.Variables,- Data.Comp.Multi.Ops, Data.Comp.Ops+ Data.Comp.Multi.Annotation,+ Data.Comp.Multi.Show,+ Data.Comp.Multi.Equality,+ Data.Comp.Multi.Variables,+ Data.Comp.Multi.Ops,+ Data.Comp.Ops,+ Data.Comp.Multi.Derive+ Data.Comp.Multi.Generic,+ Data.Comp.Multi.Desugar, - 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.Param,+ Data.Comp.Param.Term,+ Data.Comp.Param.FreshM,+ Data.Comp.Param.Any,+ 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.MultiParam,+ Data.Comp.MultiParam.Term,+ Data.Comp.MultiParam.FreshM,+ Data.Comp.MultiParam.Any,+ 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++ 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.LiftSum, Data.Comp.Derive.Foldable, Data.Comp.Derive.Traversable,- Data.Comp.Derive.Multi.Functor,- Data.Comp.Derive.Multi.Foldable,- Data.Comp.Derive.Multi.Traversable,- Data.Comp.Derive.Multi.Equality,- Data.Comp.Derive.Multi.Show,- Data.Comp.Derive.Multi.SmartConstructors+ Data.Comp.Derive.Injections,+ Data.Comp.Derive.Projections, - Build-Depends: base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, th-expand-syns+ Data.Comp.Multi.Derive.Functor,+ Data.Comp.Multi.Derive.Foldable,+ Data.Comp.Multi.Derive.Traversable,+ Data.Comp.Multi.Derive.Equality,+ Data.Comp.Multi.Derive.Show,+ Data.Comp.Multi.Derive.SmartConstructors+ Data.Comp.Multi.Derive.SmartAConstructors+ Data.Comp.Multi.Derive.LiftSum,+ 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.LiftSum,+ 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.LiftSum,+ 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 hs-source-dirs: src ghc-options: -W+ if flag(benchmark)+ buildable: False Executable test Main-is: Data_Test.hs- Build-Depends: base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, test-framework, test-framework-quickcheck2, derive, th-expand-syns, deepseq- hs-source-dirs: src testsuite/tests+ Build-Depends: base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, test-framework, test-framework-quickcheck2, derive, th-expand-syns, deepseq, transformers+ hs-source-dirs: src testsuite/tests examples ghc-options: -fhpc if !flag(test) buildable: False Executable benchmark Main-is: Benchmark.hs- Build-Depends: base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns+ Build-Depends: base == 4.*, template-haskell, containers, mtl, QuickCheck >= 2, derive, deepseq, criterion, random, uniplate, th-expand-syns, transformers hs-source-dirs: src benchmark ghc-options: -W -O2 -- Disable short-cut fusion rules in order to compare optimised and unoptimised code.
+ examples/Examples/Automata.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE RankNTypes #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Automata+-- Copyright : (c) 2010-2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines tree automata based on compositional data types.+--+--------------------------------------------------------------------------------++module Examples.Automata where++import Data.Comp+import Data.Maybe+import Data.Traversable+import Control.Monad+++{-| This type represents transition functions of deterministic+bottom-up tree acceptors (DUTAs). -}++type DUTATrans f q = Alg f q++{-| This data type represents deterministic bottom-up tree acceptors (DUTAs).+-}+data DUTA f q = DUTA {+ dutaTrans :: DUTATrans f q,+ dutaAccept :: q -> Bool+ }++{-| This function runs the transition function of a DUTA on the given+term. -}++runDUTATrans :: Functor f => DUTATrans f q -> Term f -> q+runDUTATrans = cata++{-| This function checks whether a given DUTA accepts a term. -}++duta :: Functor f => DUTA f q -> Term f -> Bool+duta DUTA{dutaTrans = trans, dutaAccept = accept} = accept . runDUTATrans trans++++{-| This type represents transition functions of non-deterministic+bottom-up tree acceptors (NUTAs). -}++type NUTATrans f q = AlgM [] f q+++{-| This type represents non-deterministic bottom-up tree acceptors.+-}+data NUTA f q = NUTA {+ nutaTrans :: AlgM [] f q,+ nutaAccept :: q -> Bool+ }++{-| This function runs the given transition function of a NUTA on the+given term -}++runNUTATrans :: Traversable f => NUTATrans f q -> Term f -> [q]+runNUTATrans = cataM++{-| This function checks whether a given NUTA accepts a term. -}++nuta :: Traversable f => NUTA f q -> Term f -> Bool+nuta NUTA{nutaTrans = trans, nutaAccept = accept} = any accept . runNUTATrans trans+++{-| This function determinises the given NUTA. -}++determNUTA :: (Traversable f) => NUTA f q -> DUTA f [q]+determNUTA n = DUTA{+ dutaTrans = algM $ nutaTrans n,+ dutaAccept = any $ nutaAccept n}++{-| This function represents transition functions of+deterministic bottom-up tree transducers (DUTTs). -}++type DUTTTrans f g q = forall a. f (q,a) -> (q, Cxt Hole g a)++{-| This function transforms a DUTT transition function into an+algebra. -}++duttTransAlg :: (Functor f, Functor g) => DUTTTrans f g q -> Alg f (q, Term g)+duttTransAlg trans = fmap injectCxt . trans ++{-| This function runs the given DUTT transition function on the given+term. -}++runDUTTTrans :: (Functor f, Functor g) => DUTTTrans f g q -> Term f -> (q, Term g)+runDUTTTrans = cata . duttTransAlg++{-| This data type represents deterministic bottom-up tree+transducers. -}++data DUTT f g q = DUTT {+ duttTrans :: DUTTTrans f g q,+ duttAccept :: q -> Bool+ }++{-| This function transforms the given term according to the given+DUTT and returns the resulting term provided it is accepted by the+DUTT. -}++dutt :: (Functor f, Functor g) => DUTT f g q -> Term f -> Maybe (Term g)+dutt DUTT{duttTrans = trans, duttAccept = accept} = accept' . runDUTTTrans trans+ where accept' (q,res)+ | accept q = Just res+ | otherwise = Nothing++{-| This type represents transition functions of non-deterministic+bottom-up tree transducers (NUTTs). -}++type NUTTTrans f g q = forall a. f (q,a) -> [(q, Cxt Hole g a)]++{-| This function transforms a NUTT transition function into a monadic+algebra. -}++nuttTransAlg :: (Functor f, Functor g) => NUTTTrans f g q -> AlgM [] f (q, Term g)+nuttTransAlg trans = liftM (fmap injectCxt) . trans ++{-| This function runs the given NUTT transition function on the given+term. -}++runNUTTTrans :: (Traversable f, Functor g) => NUTTTrans f g q -> Term f -> [(q, Term g)]+runNUTTTrans = cataM . nuttTransAlg++{-| This data type represents non-deterministic bottom-up tree+transducers (NUTTs). -}++data NUTT f g q = NUTT {+ nuttTrans :: NUTTTrans f g q,+ nuttAccept :: q -> Bool+ }++{-| This function transforms the given term according to the given+NUTT and returns a list containing all accepted results. -}++nutt :: (Traversable f, Functor g) => NUTT f g q -> Term f -> [Term g]+nutt NUTT{nuttTrans = trans, nuttAccept = accept} = mapMaybe accept' . runNUTTTrans trans+ where accept' (q,res)+ | accept q = Just res+ | otherwise = Nothing
+ examples/Examples/DesugarEval.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances,+ OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.DesugarEval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Expression Evaluation+--+-- The example illustrates how to compose a term homomorphism and an algebra,+-- exemplified via a desugaring term homomorphism and an evaluation algebra.+--+--------------------------------------------------------------------------------++module Examples.DesugarEval where++import Data.Comp+import Data.Comp.Show ()+import Data.Comp.Derive+import Data.Comp.Desugar++-- Signature for values, operators, and syntactic sugar+data Value e = Const Int | Pair e e+data Op e = Add e e | Mult e e | Fst e | Snd e+data Sugar e = Neg e | Swap e++-- Signature for the simple expression language+type Sig = Op :+: Value++-- Signature for the simple expression language, extended with syntactic sugar+type Sig' = Sugar :+: Op :+: Value++-- Derive boilerplate code using Template Haskell+$(derive [makeFunctor, makeTraversable, makeFoldable,+ makeEqF, makeShowF, smartConstructors]+ [''Value, ''Op, ''Sugar])++instance (Op :<: f, Value :<: f, Functor f) => Desugar Sugar f 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)++$(derive [liftSum] [''Eval])++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+projC v = case project v of Just (Const n) -> n++projP :: (Value :<: v) => Term v -> (Term v, Term v)+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++evalDesug :: Term Sig' -> Term Value+evalDesug = eval . desugar++-- Example: evalEx = iPair (iConst 2) (iConst 1)+evalEx :: Term Value+evalEx = evalDesug $ iSwap $ iPair (iConst 1) (iConst 2)
+ examples/Examples/DesugarPos.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances,+ OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.DesugarPos+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Propagation of Annotations+--+-- The example illustrates how to lift a term homomorphism to products,+-- exemplified via a desugaring term homomorphism lifted to terms annotated with+-- source position information.+--+--------------------------------------------------------------------------------++module Examples.DesugarPos where++import Data.Comp+import Data.Comp.Show ()+import Data.Comp.Equality ()+import Data.Comp.Derive+import Data.Comp.Desugar++-- Signature for values, operators, and syntactic sugar+data Value e = Const Int | Pair e e+data Op e = Add e e | Mult e e | Fst e | Snd e+data Sugar e = Neg e | Swap e++-- 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+$(derive [makeFunctor, makeTraversable, makeFoldable,+ makeEqF, makeShowF, smartConstructors, smartAConstructors]+ [''Value, ''Op, ''Sugar])++instance (Op :<: f, Value :<: f, Functor f) => Desugar Sugar f where+ desugHom' (Neg x) = iConst (-1) `iMult` x+ desugHom' (Swap x) = iSnd x `iPair` iFst x++-- Example: desugEx = iPair (iConst 2) (iConst 1)+desugEx :: Term Sig+desugEx = desugar (iSwap $ iPair (iConst 1) (iConst 2) :: Term Sig')++-- Lift desugaring to terms annotated with source positions+desugP :: Term SigP' -> Term SigP+desugP = appTermHom (propAnn desugHom)++-- Example: desugPEx = iAPair (Pos 1 0)+-- (iASnd (Pos 1 0) (iAPair (Pos 1 1)+-- (iAConst (Pos 1 2) 1)+-- (iAConst (Pos 1 3) 2)))+-- (iAFst (Pos 1 0) (iAPair (Pos 1 1)+-- (iAConst (Pos 1 2) 1)+-- (iAConst (Pos 1 3) 2)))+desugPEx :: Term SigP+desugPEx = desugP $ iASwap (Pos 1 0) (iAPair (Pos 1 1) (iAConst (Pos 1 2) 1)+ (iAConst (Pos 1 3) 2))
+ examples/Examples/Eval.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Eval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Expression Evaluation+--+-- The example illustrates how to use compositional data types to implement+-- a small expression language, with a sub language of values, and an evaluation+-- function mapping expressions to values.+--+--------------------------------------------------------------------------------++module Examples.Eval where++import Data.Comp+import Data.Comp.Show ()+import Data.Comp.Derive++-- Signature for values and operators+data Value e = Const Int | Pair e e+data Op e = Add e e | Mult e e | Fst e | Snd e++-- Signature for the simple expression language+type Sig = Op :+: Value++-- Derive boilerplate code using Template Haskell+$(derive [makeFunctor, makeShowF,+ makeEqF, smartConstructors] [''Value, ''Op])++-- Term evaluation algebra+class Eval f v where+ evalAlg :: Alg f (Term v)++$(derive [liftSum] [''Eval])++-- Lift the evaluation algebra to a catamorphism+eval :: (Functor 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+projC v = case project v of Just (Const n) -> n++projP :: (Value :<: v) => Term v -> (Term v, Term v)+projP v = case project v of Just (Pair x y) -> (x,y)++-- Example: evalEx = iConst 5+evalEx :: Term Value+evalEx = eval ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
+ examples/Examples/EvalM.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.EvalM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Monadic Expression Evaluation+--+-- The example illustrates how to use compositional data types to implement+-- a small expression language, with a sub language of values, and a monadic+-- evaluation function mapping expressions to values.+--+--------------------------------------------------------------------------------++module Examples.EvalM where++import Data.Comp+import Data.Comp.Derive+import Control.Monad (liftM)++-- Signature for values and operators+data Value e = Const Int | Pair e e+data Op e = Add e e | Mult e e | Fst e | Snd e++-- Signature for the simple expression language+type Sig = Op :+: Value++-- Derive boilerplate code using Template Haskell+$(derive [makeFunctor, makeTraversable, makeFoldable,+ makeEqF, makeShowF, smartConstructors]+ [''Value, ''Op])++-- Monadic term evaluation algebra+class EvalM f v where+ evalAlgM :: AlgM Maybe f (Term v)++$(derive [liftSum] [''EvalM])++-- Lift the monadic evaluation algebra to a monadic catamorphism+evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v)+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+ return $ iConst $ n1 + n2+ evalAlgM (Mult x y) = do n1 <- projC x+ n2 <- projC y+ return $ iConst $ n1 * n2+ evalAlgM (Fst v) = liftM fst $ projP v+ evalAlgM (Snd v) = liftM snd $ projP v++projC :: (Value :<: v) => Term v -> Maybe Int+projC v = case project v of+ Just (Const n) -> return n+ _ -> Nothing++projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v)+projP v = case project v of+ Just (Pair x y) -> return (x,y)+ _ -> Nothing++-- Example: evalMEx = Just (iConst 5)+evalMEx :: Maybe (Term Value)+evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
+ examples/Examples/GTermHom.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances,+ FlexibleContexts, UndecidableInstances, TemplateHaskell, TypeOperators,+ ImplicitParams, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.GTermHom+-- Copyright : (c) 2010-2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+--+--------------------------------------------------------------------------------++module Examples.GTermHom where++import Data.Comp+import Data.Comp.Show ()+import Data.Map (Map)+import Data.Maybe+import qualified Data.Map as Map+import Control.Monad+import Data.Comp.Derive++-- | An instance @a :< b@ means that @a@ is a component of @b@. @a@+-- can be extracted from @b@ via the method 'ex'.+class a :< b where+ ex :: b -> a++instance a :< a where+ ex = id++instance a :< (a,b) where+ ex = fst++instance (a :< b) => a :< (a',b) where+ ex = ex . snd++-- | This function provides access to components of the states from+-- "below".+below :: (?below :: a -> q, p :< q) => a -> p+below = ex . ?below++-- | This function provides access to components of the state from+-- "above"+above :: (?above :: q, p :< q) => p+above = ex ?above++-- | This type represents generalised term homomorphisms. Generalised+-- term homomorphisms have access to a state that is provided+-- (separately) by a DUTA or a DDTA (or both).+type GTermHom q f g = forall a . (?below :: a -> q, ?above :: q) => f a -> Context g a++class Functor f => Zippable f where+ fzip :: f a -> [b] -> Maybe (f (a,b))+ fzip = fzipWith (\ x y -> (x,y))+ fzipWith :: (a -> b -> c) -> f a -> [b] -> Maybe (f c)+ fzipWith f s l = fmap (fmap $ uncurry f) (fzip s l)++-- | This type represents transition functions of deterministic+-- bottom-up tree transducers (DUTTs).++type UpTrans q f g = forall a. f (q,a) -> (q, Context g a)+++-- | This type represents transition functions of deterministic+-- bottom-up tree acceptors (DUTAs).+type UpState f q = Alg f q++-- | 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 transforms DUTT transition function into an+-- algebra.++upAlg :: (Functor g) => UpTrans q f 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 q f g -> Term f -> (q, Term g)+runUpTrans = cata . upAlg++-- | This function generalises 'runUpTrans' to contexts. Therefore,+-- additionally, a transition function for the holes is needed.+runUpTrans' :: (Functor f, Functor g) => UpTrans q f g -> (a -> q) -> Context f a -> (q, Context g a)+runUpTrans' trans st = run where+ run (Hole a) = (st a, Hole a)+ run (Term t) = fmap appCxt $ trans $ fmap run t++-- | This function composes two DUTTs.+compUpTrans :: (Functor f, Functor g, Functor h)+ => UpTrans q2 g h -> UpTrans q1 f g -> UpTrans (q1,q2) f h+compUpTrans t2 t1 x = ((q1,q2), fmap snd c2) where+ (q1, c1) = t1 $ fmap (\((q1,q2),a) -> (q1,(q2,a))) x+ (q2, c2) = runUpTrans' t2 fst c1++-- | This function turns constructs a DUTT from a given generalised+-- term homomorphism with the state propagated by the given DUTA.+toUpTrans :: (Functor f, Functor g) => UpState f q -> GTermHom q f g -> UpTrans q f g+toUpTrans alg f t = (q, c)+ where q = alg $ fmap fst t+ c = fmap snd $ (let ?below = fst; ?above = q in f t)++-- | This function applies a given generalised term homomorphism with+-- a state space propagated by the given DUTA to a term.+upTermHom :: (Functor f, Functor g) => UpState f q -> GTermHom q f g -> Term f -> (q,Term g)+upTermHom alg h = runUpTrans (toUpTrans alg h)++-- | This function generalised 'upTermHom' to contexts. To this end+-- also a transition function for holes is required.+upTermHom' :: (Functor f, Functor g) => UpState f q -> GTermHom q f g -> (a -> q) -> Context f a -> (q, Context g a)+upTermHom' alg h = runUpTrans' (toUpTrans alg h)+++-- | This type represents transition functions of deterministic+-- top-down tree transducers (DDTTs).++type DownTrans q f g = forall a. (q, f a) -> Context g (q,a)++-- | This function runs the given DDTT on the given tree.+runDownTrans :: (Functor f, Functor g) => DownTrans q f 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 q f 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.+compDownTrans :: (Functor f, Functor g, Functor h)+ => DownTrans p g h -> DownTrans q f g -> DownTrans (q,p) f h+compDownTrans t2 t1 ((q,p), t) = fmap (\(p, (q, a)) -> ((q,p),a)) $ runDownTrans' t2 p (t1 (q, 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++-- | 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 product DDTA of the given two DDTAs.+prodDownState :: DownState f p -> DownState f q -> DownState f (p,q)+prodDownState sp sq ((p,q),t) = Map.map final $ Map.unionWith combine ps qs+ where ps = Map.map LState $ sp (p, t)+ qs = Map.map RState $ sq (q, t)+ 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)++-- | This type is used for applying a DDTAs.+newtype Numbered a = Numbered (a, Int)++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 constructs a DDTT from a given generalised term+-- homomorphism with the state propagated by the given DDTA.+toDownTrans :: Zippable f => DownState f q -> GTermHom q f g -> DownTrans q f g+toDownTrans st f (q, s) = c+ where s' = fromJust $ fzipWith (curry Numbered) s [0 ..]+ qmap = st (q,s')+ qfun = \ k@(Numbered (a,_)) -> (Map.findWithDefault q k qmap ,a)+ s'' = fmap qfun s'+ c = (let ?above = q; ?below = fst in f) s''+++-- | This function applies a given generalised term homomorphism with+-- a state space propagated by the given DUTA to a term.+downTermHom :: (Zippable f, Functor g)+ => DownState f q -> GTermHom q f g -> q -> Term f -> Term g+downTermHom st h = runDownTrans (toDownTrans st h)+++-------------+-- Example --+-------------++data Str a = Str+data Base a = Char | List a++type Typ = Str :+: Base++$(derive [makeFunctor,smartConstructors, makeShowF] [''Str,''Base])++class StringType f g where+ strTypeHom :: (Bool :< q) => GTermHom q f g++$(derive [liftSum] [''StringType])++strType :: (Base :<: f, Functor f, Functor g, StringType f g)+ => Term f -> Term g+strType = snd . upTermHom isCharAlg strTypeHom++isCharAlg :: (Base :<: f) => Alg f Bool+isCharAlg t = case proj t of+ Just Char -> True+ _ -> False+ +instance (Str :<: f, Functor f) => StringType Str f where+ strTypeHom = simpCxt . inj++instance (Str :<: f, Base :<: f, Functor f) => StringType Base f where+ strTypeHom Char = iChar+ strTypeHom (List t)+ | below t = iStr + | otherwise = iList $ Hole t+++ex1 :: Term Typ+ex1 = iList iChar++runEx1 :: Term Typ+runEx1 = strType ex1
+ examples/Examples/Multi/DesugarEval.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,+ OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Multi.DesugarEval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Expression Evaluation+--+-- The example illustrates how to compose a term homomorphism and an algebra,+-- exemplified via a desugaring term homomorphism and an evaluation algebra.+--+--------------------------------------------------------------------------------++module Examples.Multi.DesugarEval where++import Data.Comp.Multi+import Data.Comp.Multi.Show ()+import Data.Comp.Multi.Derive+import Data.Comp.Multi.Desugar++-- Signature for values, operators, and syntactic sugar+data Value e l where+ Const :: Int -> Value e Int+ Pair :: e s -> e t -> Value e (s,t)+data Op e l where+ Add, Mult :: e Int -> e Int -> Op e Int+ Fst :: e (s,t) -> Op e s+ Snd :: e (s,t) -> Op e t+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])++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)++$(derive [liftSum] [''Eval])++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 :: TermHom Sig' Sig))++-- Example: evalEx = iPair (iConst 2) (iConst 1)+evalEx :: Term Value (Int,Int)+evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)
+ examples/Examples/Multi/DesugarPos.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,+ OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Multi.DesugarPos+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Propagation of Annotations+--+-- The example illustrates how to lift a term homomorphism to products,+-- exemplified via a desugaring term homomorphism lifted to terms annotated with+-- source position information.+--+--------------------------------------------------------------------------------++module Examples.Multi.DesugarPos where++import Data.Comp.Multi+import Data.Comp.Multi.Show ()+import Data.Comp.Multi.Derive+import Data.Comp.Multi.Desugar++-- Signature for values, operators, and syntactic sugar+data Value e l where+ Const :: Int -> Value e Int+ Pair :: e s -> e t -> Value e (s,t)+data Op e l where+ Add, Mult :: e Int -> e Int -> Op e Int+ Fst :: e (s,t) -> Op e s+ Snd :: e (s,t) -> Op e t+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, smartAConstructors]+ [''Value, ''Op, ''Sugar])++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++-- Example: desugEx = iPair (iConst 2) (iConst 1)+desugEx :: Term Sig (Int,Int)+desugEx = desugar (iSwap $ iPair (iConst 1) (iConst 2) :: Term Sig' (Int,Int))++-- Example: desugPEx = iAPair (Pos 1 0)+-- (iASnd (Pos 1 0) (iAPair (Pos 1 1)+-- (iAConst (Pos 1 2) 1)+-- (iAConst (Pos 1 3) 2)))+-- (iAFst (Pos 1 0) (iAPair (Pos 1 1)+-- (iAConst (Pos 1 2) 1)+-- (iAConst (Pos 1 3) 2)))+desugPEx :: Term SigP (Int,Int)+desugPEx = desugarA (iASwap (Pos 1 0) (iAPair (Pos 1 1) (iAConst (Pos 1 2) 1)+ (iAConst (Pos 1 3) 2))+ :: Term SigP' (Int,Int))
+ examples/Examples/Multi/Eval.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Multi.Eval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Expression Evaluation+--+-- 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.+--+--------------------------------------------------------------------------------++module Examples.Multi.Eval where++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+ Pair :: e s -> e t -> Value e (s,t)+data Op e l where+ 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] + [''Value, ''Op])++-- Term evaluation algebra+class Eval f v where+ evalAlg :: Alg f (Term v)++$(derive [liftSum] [''Eval])++-- 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)
+ examples/Examples/Multi/EvalI.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Multi.EvalI+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Intrinsic Expression Evaluation+--+-- 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.+--+--------------------------------------------------------------------------------++module Examples.Multi.EvalI where++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+ Pair :: e s -> e t -> Value e (s,t)+data Op e l where+ 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] + [''Value, ''Op])++-- Term evaluation algebra+class EvalI f where+ evalAlgI :: Alg f I++$(derive [liftSum] [''EvalI])++-- 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)
+ examples/Examples/Multi/EvalM.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Multi.EvalM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Monadic Expression Evaluation+--+-- The example illustrates how to use generalised compositional data types to+-- implement a small expression language, with a sub language of values, and a +-- monadic evaluation function mapping expressions to values.+--+--------------------------------------------------------------------------------++module Examples.Multi.EvalM where++import Data.Comp.Multi+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+ Pair :: e s -> e t -> Value e (s,t)+data Op e l where+ 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)++$(derive [liftSum] [''EvalM])++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+ return $ iConst $ n1 + n2+ evalAlgM (Mult x y) = do n1 <- projC x+ n2 <- projC y+ 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`+ (iConst 2 `iMult` iConst 2) :: Term Sig Int)
+ examples/Examples/MultiParam/DesugarEval.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances,+ TypeSynonymInstances, OverlappingInstances, GADTs, KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.MultiParam.DesugarEval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Expression Evaluation+--+-- The example illustrates how to compose a term homomorphism and an algebra,+-- exemplified via a desugaring term homomorphism and an evaluation algebra.+--+-- The example extends the example from 'Examples.MultiParam.Eval'.+--+--------------------------------------------------------------------------------++module Examples.MultiParam.DesugarEval where++import Data.Comp.MultiParam hiding (Const)+import Data.Comp.MultiParam.Show ()+import Data.Comp.MultiParam.Derive+import Data.Comp.MultiParam.Desugar++-- Signatures for values and operators+data Const :: (* -> *) -> (* -> *) -> * -> * where+ Const :: Int -> Const a e Int+data Lam :: (* -> *) -> (* -> *) -> * -> * where+ Lam :: (a i -> e j) -> Lam a e (i -> j)+data App :: (* -> *) -> (* -> *) -> * -> * where+ App :: e (i -> j) -> e i -> App a e j+data Op :: (* -> *) -> (* -> *) -> * -> * where+ Add :: e Int -> e Int -> Op a e Int+ Mult :: e Int -> e Int -> Op a e Int+data Fun :: (* -> *) -> (* -> *) -> * -> * where+ Fun :: (e i -> e j) -> Fun a e (i -> j)+data IfThenElse :: (* -> *) -> (* -> *) -> * -> * where+ IfThenElse :: (e Int) -> (e i) -> (e i) -> IfThenElse a e i++-- Signature for syntactic sugar (negation, let expressions)+data Sug :: (* -> *) -> (* -> *) -> * -> * where+ Neg :: e Int -> Sug a e Int+ Let :: e i -> (a i -> e j) -> Sug a e j++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op :+: IfThenElse+-- Signature for the simple expression language with syntactic sugar+type Sig' = Sug :+: Sig+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)+type Value = Const :+: Fun+-- Signature for ground values.+type GValue = Const++-- Derive boilerplate code using Template Haskell+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op, ''IfThenElse, ''Sug])+$(derive [makeHFoldable, makeHTraversable]+ [''Const, ''App, ''Op])+$(derive [smartConstructors] [''Fun])++instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, HDifunctor f)+ => Desugar Sug f where+ desugHom' (Neg x) = iConst (-1) `iMult` x+ desugHom' (Let x y) = iLam y `iApp` x++-- Term evaluation algebra+class Eval f v where+ evalAlg :: Alg f (Term v)++$(derive [liftSum] [''Eval])++-- Compose the evaluation algebra and the desugaring homomorphism to an algebra+eval :: Term Sig' :-> Term Value+eval = cata (evalAlg `compAlg` (desugHom :: TermHom Sig' Sig))++instance (Const :<: v) => Eval Const v where+ evalAlg (Const n) = iConst n++instance (Const :<: v) => Eval Op v where+ evalAlg (Add x y) = iConst $ (projC x) + (projC y)+ evalAlg (Mult x y) = iConst $ (projC x) * (projC y)++instance (Fun :<: v) => Eval App v where+ evalAlg (App x y) = (projF x) y++instance (Fun :<: v) => Eval Lam v where+ evalAlg (Lam f) = iFun f++instance (Const :<: v) => Eval IfThenElse v where+ evalAlg (IfThenElse c v1 v2) = if projC c /= 0 then v1 else v2++projC :: (Const :<: v) => Term v Int -> Int+projC v = case project v of Just (Const n) -> n++projF :: (Fun :<: v) => Term v (i -> j) -> Term v i -> Term v j+projF v = case project v of Just (Fun f) -> f++-- |Evaluation of expressions to ground values.+evalG :: Term Sig' i -> Maybe (Term GValue i)+evalG = deepProject . (eval :: Term Sig' :-> Term Value)++-- Example: evalEx = Just (iConst -6)+evalEx :: Maybe (Term GValue Int)+evalEx = evalG $ iLet (iConst 6) $ \x -> iNeg $ Place x
+ examples/Examples/MultiParam/DesugarPos.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances,+ TypeSynonymInstances, OverlappingInstances, GADTs, KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.MultiParam.DesugarPos+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Propagation of Annotations.+--+-- The example illustrates how to compose a term homomorphism and an algebra,+-- exemplified via a desugaring term homomorphism and an evaluation algebra.+--+--------------------------------------------------------------------------------++module Examples.MultiParam.DesugarPos where++import Data.Comp.MultiParam hiding (Const)+import Data.Comp.MultiParam.Show ()+import Data.Comp.MultiParam.Derive+import Data.Comp.MultiParam.Desugar++-- Signatures for values and operators+data Const :: (* -> *) -> (* -> *) -> * -> * where+ Const :: Int -> Const a e Int+data Lam :: (* -> *) -> (* -> *) -> * -> * where+ Lam :: (a i -> e j) -> Lam a e (i -> j)+data App :: (* -> *) -> (* -> *) -> * -> * where+ App :: e (i -> j) -> e i -> App a e j+data Op :: (* -> *) -> (* -> *) -> * -> * where+ Add :: e Int -> e Int -> Op a e Int+ Mult :: e Int -> e Int -> Op a e Int+data Fun :: (* -> *) -> (* -> *) -> * -> * where+ Fun :: (e i -> e j) -> Fun a e (i -> j)+data IfThenElse :: (* -> *) -> (* -> *) -> * -> * where+ IfThenElse :: (e Int) -> (e i) -> (e i) -> IfThenElse a e i++-- Signature for syntactic sugar (negation, let expressions)+data Sug :: (* -> *) -> (* -> *) -> * -> * where+ Neg :: e Int -> Sug a e Int+ Let :: e i -> (a i -> e j) -> Sug a e j++-- Source position information (line number, column number)+data Pos = Pos Int Int+ deriving (Show, Eq)++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op+type SigP = Const :&: Pos :+: Lam :&: Pos :+: App :&: Pos :+: Op :&: Pos++-- Signature for the simple expression language, extended with syntactic sugar+type Sig' = Sug :+: Sug+type SigP' = Sug :&: Pos :+: SigP++-- Derive boilerplate code using Template Haskell+$(derive [makeHDifunctor, makeEqHD, makeShowHD,+ smartConstructors, smartAConstructors]+ [''Const, ''Lam, ''App, ''Op, ''Sug])++instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, HDifunctor f)+ => Desugar Sug f where+ desugHom' (Neg x) = iConst (-1) `iMult` x+ desugHom' (Let x y) = iLam y `iApp` x++-- Example: desugPEx == iAApp (Pos 1 0)+-- (iALam (Pos 1 0) $ \x -> iAMult (Pos 1 2) (iAConst (Pos 1 2) (-1)) (Place x))+-- (iAConst (Pos 1 1) 6)+desugPEx :: Term SigP Int+desugPEx = desugarA (iALet (Pos 1 0)+ (iAConst (Pos 1 1) 6)+ (\x -> iANeg (Pos 1 2) $ Place x :: Term SigP' Int))
+ examples/Examples/MultiParam/Eval.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,+ KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.MultiParam.Eval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Expression Evaluation+--+-- The example illustrates how to use generalised parametric compositional data+-- types to implement a small expression language, with a language of values,+-- and an evaluation function mapping typed expressions to typed values. The+-- example demonstrates how (parametric) abstractions are mapped to general+-- functions, from values to values, and how it is possible to project a general+-- value (with functions) back into ground values, that can again be analysed.+--+-- The following language extensions are needed in order to run the example:+-- @TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+-- @FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, @GADTs@,+-- and @KindSignatures@.+--+--------------------------------------------------------------------------------++module Examples.MultiParam.Eval where++import Data.Comp.MultiParam hiding (Const)+import Data.Comp.MultiParam.Show ()+import Data.Comp.MultiParam.Derive++-- Signatures for values and operators+data Const :: (* -> *) -> (* -> *) -> * -> * where+ Const :: Int -> Const a e Int+data Lam :: (* -> *) -> (* -> *) -> * -> * where+ Lam :: (a i -> e j) -> Lam a e (i -> j)+data App :: (* -> *) -> (* -> *) -> * -> * where+ App :: e (i -> j) -> e i -> App a e j+data Op :: (* -> *) -> (* -> *) -> * -> * where+ Add :: e Int -> e Int -> Op a e Int+ Mult :: e Int -> e Int -> Op a e Int+data Fun :: (* -> *) -> (* -> *) -> * -> * where+ Fun :: (e i -> e j) -> Fun a e (i -> j)++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)+type Value = Const :+: Fun+-- Signature for ground values.+type GValue = Const++-- Derive boilerplate code using Template Haskell+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op])+$(derive [makeHFoldable, makeHTraversable]+ [''Const, ''App, ''Op])+$(derive [smartConstructors] [''Fun])++-- Term evaluation algebra+class Eval f v where+ evalAlg :: Alg f (Term v)++$(derive [liftSum] [''Eval])++-- Lift the evaluation algebra to a catamorphism+eval :: (HDifunctor f, Eval f v) => Term f :-> Term v+eval = cata evalAlg++instance (Const :<: v) => Eval Const v where+ evalAlg (Const n) = iConst n++instance (Const :<: v) => Eval Op v where+ evalAlg (Add x y) = iConst $ (projC x) + (projC y)+ evalAlg (Mult x y) = iConst $ (projC x) * (projC y)++instance (Fun :<: v) => Eval App v where+ evalAlg (App x y) = (projF x) y++instance (Fun :<: v) => Eval Lam v where+ evalAlg (Lam f) = iFun f++projC :: (Const :<: v) => Term v Int -> Int+projC v = case project v of Just (Const n) -> n++projF :: (Fun :<: v) => Term v (i -> j) -> Term v i -> Term v j+projF v = case project v of Just (Fun f) -> f++-- |Evaluation of expressions to ground values.+evalG :: Term Sig i -> Maybe (Term GValue i)+evalG = deepProject . (eval :: Term Sig :-> Term Value)++-- Example: evalEx = Just (iConst 4)+evalEx :: Maybe (Term GValue Int)+evalEx = evalG $ (iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
+ examples/Examples/MultiParam/EvalAlgM.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,+ KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.MultiParam.EvalAlgM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Monadic Expression Evaluation without PHOAS+--+-- The example illustrates how to use generalised parametric compositional+-- data types to implement a small expression language, with a sub language of+-- values, and a monadic evaluation function mapping expressions to values.+-- The lack of PHOAS means that -- unlike the example in+-- 'Examples.MultiParam.EvalM' -- a monadic algebra can be used.+--+--------------------------------------------------------------------------------++module Examples.MultiParam.EvalAlgM where++import Data.Comp.MultiParam+import Data.Comp.MultiParam.Show ()+import Data.Comp.MultiParam.HDitraversable+import Data.Comp.MultiParam.Derive+import Control.Monad (liftM)++-- Signature for values and operators+data Value :: (* -> *) -> (* -> *) -> * -> * where+ Const :: Int -> Value a e Int+ Pair :: e i -> e j -> Value a e (i,j)+data Op :: (* -> *) -> (* -> *) -> * -> * where+ Add :: e Int -> e Int -> Op a e Int+ Mult :: e Int -> e Int -> Op a e Int+ Fst :: e (i,j) -> Op a e i+ Snd :: e (i,j) -> Op a e j++-- Signature for the simple expression language+type Sig = Op :+: Value++-- Derive boilerplate code using Template Haskell+$(derive [makeHDifunctor, makeHTraversable, makeHFoldable,+ makeEqHD, makeShowHD, smartConstructors]+ [''Value, ''Op])++-- Monadic term evaluation algebra+class EvalM f v where+ evalAlgM :: AlgM Maybe f (Term v)++$(derive [liftSum] [''EvalM])++-- Lift the monadic evaluation algebra to a monadic catamorphism+evalM :: (HDitraversable f Maybe (Term v), EvalM f v)+ => Term f i -> Maybe (Term v i)+evalM = cataM evalAlgM++instance (Value :<: v) => EvalM Value v where+ evalAlgM (Const n) = return $ iConst n+ evalAlgM (Pair x y) = return $ iPair x y++instance (Value :<: v) => EvalM Op v where+ evalAlgM (Add x y) = do n1 <- projC x+ n2 <- projC y+ return $ iConst $ n1 + n2+ evalAlgM (Mult x y) = do n1 <- projC x+ n2 <- projC y+ 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 (i,j) -> Maybe (Term v i, Term v j)+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` (iConst 2 `iMult` iConst 2) :: Term Sig Int)
+ examples/Examples/MultiParam/EvalI.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,+ KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.MultiParam.EvalI+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Intrinsic Expression Evaluation+--+-- The example illustrates how to use generalised parametric compositional data+-- types to implement a small expression language, and an evaluation function+-- mapping typed expressions to values.+--+--------------------------------------------------------------------------------++module Examples.MultiParam.EvalI where++import Data.Comp.MultiParam hiding (Const)+import Data.Comp.MultiParam.Show ()+import Data.Comp.MultiParam.Derive++-- Signatures for values and operators+data Const :: (* -> *) -> (* -> *) -> * -> * where+ Const :: Int -> Const a e Int+data Lam :: (* -> *) -> (* -> *) -> * -> * where+ Lam :: (a i -> e j) -> Lam a e (i -> j)+data App :: (* -> *) -> (* -> *) -> * -> * where+ App :: e (i -> j) -> e i -> App a e j+data Op :: (* -> *) -> (* -> *) -> * -> * where+ Add :: e Int -> e Int -> Op a e Int+ Mult :: e Int -> e Int -> Op a e Int++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op++-- Derive boilerplate code using Template Haskell+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op])+$(derive [makeHFoldable, makeHTraversable]+ [''Const, ''App, ''Op])++-- Term evaluation algebra+class Eval f where+ evalAlg :: Alg f I+ evalAlg = I . evalAlg'+ evalAlg' :: f I I i -> i+ evalAlg' = unI . evalAlg++$(derive [liftSum] [''Eval])++-- Lift the evaluation algebra to a catamorphism+eval :: (HDifunctor f, Eval f) => Term f i -> i+eval = unI . cata evalAlg++instance Eval Const where+ evalAlg' (Const n) = n++instance Eval Op where+ evalAlg' (Add (I x) (I y)) = x + y+ evalAlg' (Mult (I x) (I y)) = x * y++instance Eval App where+ evalAlg' (App (I f) (I x)) = f x++instance Eval Lam where+ evalAlg' (Lam f) = unI . f . I++-- Example: evalEx = 4+evalEx :: Int+evalEx = eval $ ((iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2+ :: Term Sig Int)
+ examples/Examples/MultiParam/EvalM.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances, GADTs,+ KindSignatures, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.MultiParam.EvalM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Monadic Expression Evaluation+--+-- The example illustrates how to use generalised parametric compositional data+-- types to implement a small expression language, with a language of values,+-- and a monadic evaluation function mapping expressions to values. The example+-- demonstrates how (parametric) abstractions are mapped to general functions,+-- from values to /monadic/ values, and how it is possible to project a general+-- value (with functions) back into ground values, that can again be analysed.+--+--------------------------------------------------------------------------------++module Examples.MultiParam.EvalM where++import Data.Comp.MultiParam hiding (Const)+import Data.Comp.MultiParam.Show ()+import Data.Comp.MultiParam.Derive+import Control.Monad ((<=<))++-- Signatures for values and operators+data Const :: (* -> *) -> (* -> *) -> * -> * where+ Const :: Int -> Const a e Int+data Lam :: (* -> *) -> (* -> *) -> * -> * where+ Lam :: (a i -> e j) -> Lam a e (i -> j)+data App :: (* -> *) -> (* -> *) -> * -> * where+ App :: e (i -> j) -> e i -> App a e j+data Op :: (* -> *) -> (* -> *) -> * -> * where+ Add :: e Int -> e Int -> Op a e Int+ Mult :: e Int -> e Int -> Op a e Int+data FunM :: (* -> *) -> (* -> *) -> (* -> *) -> * -> * where+ FunM :: (e i -> Compose m e j) -> FunM m a e (i -> j)++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op+-- Signature for values. Note the use of 'FunM' rather than 'Lam' (!)+type Value = Const :+: FunM Maybe+-- Signature for ground values.+type GValue = Const++-- Derive boilerplate code using Template Haskell+$(derive [makeHDifunctor, makeEqHD, makeShowHD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op])+$(derive [makeHFoldable, makeHTraversable]+ [''Const, ''App, ''Op])+$(derive [smartConstructors] [''FunM])++-- Term evaluation algebra.+class EvalM f v where+ evalAlgM :: AlgM' Maybe f (Term v)++$(derive [liftSum] [''EvalM])++-- Lift the evaluation algebra to a catamorphism+evalM :: (HDifunctor f, EvalM f v) => Term f i -> Maybe (Term v i)+evalM = cataM' evalAlgM++instance (Const :<: v) => EvalM Const v where+ evalAlgM (Const n) = return $ iConst n++instance (Const :<: v) => EvalM Op v where+ evalAlgM (Add mx my) = do x <- projC =<< getCompose mx+ y <- projC =<< getCompose my+ return $ iConst $ x + y+ evalAlgM (Mult mx my) = do x <- projC =<< getCompose mx+ y <- projC =<< getCompose my+ return $ iConst $ x * y++instance (FunM Maybe :<: v) => EvalM App v where+ evalAlgM (App mx my) = do f <- projF =<< getCompose mx+ (getCompose . f) =<< getCompose my++instance (FunM Maybe :<: v) => EvalM Lam v where+ evalAlgM (Lam f) = return $ iFunM f++projC :: (Const :<: v) => Term v Int -> Maybe Int+projC v = case project v of+ Just (Const n) -> return n; _ -> Nothing++projF :: (FunM Maybe :<: v)+ => Term v (i -> j) -> Maybe (Term v i -> Compose Maybe (Term v) j)+projF v = case project v of+ Just (FunM f :: FunM Maybe a (Term v) (i -> j)) -> return f+ _ -> Nothing++-- |Evaluation of expressions to ground values.+evalMG :: Term Sig i -> Maybe (Term GValue i)+evalMG = deepProject <=< (evalM :: Term Sig i -> Maybe (Term Value i))++-- Example: evalEx = Just (iConst 12) (3 * (2 + 2) = 12)+evalMEx :: Maybe (Term GValue Int)+evalMEx = evalMG $ (iLam $ \x -> iLam $ \y ->+ Place y `iMult` (Place x `iAdd` Place x))+ `iApp` iConst 2 `iApp` iConst 3
+ examples/Examples/MultiParam/FOL.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, FlexibleInstances,+ FlexibleContexts, UndecidableInstances, GADTs, KindSignatures,+ OverlappingInstances, TypeSynonymInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.MultiParam.FOL+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- First-Order Logic à la Carte+--+-- This example illustrates how to implement First-Order Logic à la Carte+-- (Knowles, The Monad.Reader Issue 11, '08) using Generalised Parametric+-- Compositional Data Types.+--+-- Rather than having a fixed domain @Term@ for binders, a la Knowles, our+-- encoding uses a mutually recursive data structure for terms and formulae.+-- This enables variables to be introduced only when they are actually needed+-- in the term language, i.e. in stage 5.+--+--------------------------------------------------------------------------------++module Examples.MultiParam.FOL where++import Data.Comp.MultiParam hiding (Const)+import Data.Comp.MultiParam.Show ()+import Data.Comp.MultiParam.Derive+import Data.Comp.MultiParam.FreshM (genVar)+import Data.List (intersperse)+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 boilerplate code using Template Haskell+$(derive [makeHDifunctor, smartConstructors]+ [''Const, ''Var, ''TT, ''FF, ''Atom, ''NAtom,+ ''Not, ''Or, ''And, ''Impl, ''Exists, ''Forall])++--------------------------------------------------------------------------------+-- Pretty printing of terms and formulae+--------------------------------------------------------------------------------++instance ShowHD Const where+ showHD (Const f t) = do+ ts <- mapM pshow t+ return $ f ++ "(" ++ concat (intersperse ", " 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 pshow t+ return $ p ++ "(" ++ concat (intersperse ", " ts) ++ ")"++instance ShowHD NAtom where+ showHD (NAtom p t) = do+ ts <- mapM pshow t+ return $ "not " ++ p ++ "(" ++ concat (intersperse ", " ts) ++ ")"++instance ShowHD Not where+ showHD (Not f) = liftM (\x -> "not (" ++ x ++ ")") (pshow f)++instance ShowHD Or where+ showHD (Or f1 f2) =+ liftM2 (\x y -> "(" ++ x ++ ") or (" ++ y ++ ")") (pshow f1) (pshow f2)++instance ShowHD And where+ showHD (And f1 f2) =+ liftM2 (\x y -> "(" ++ x ++ ") and (" ++ y ++ ")") (pshow f1) (pshow f2)++instance ShowHD Impl where+ showHD (Impl f1 f2) =+ liftM2 (\x y -> "(" ++ x ++ ") -> (" ++ y ++ ")") (pshow f1) (pshow f2)++instance ShowHD Exists where+ showHD (Exists f) = do x <- genVar+ x' <- pshow x+ b <- pshow $ f x+ return $ "exists " ++ x' ++ ". " ++ b++instance ShowHD Forall where+ showHD (Forall f) = do x <- genVar+ x' <- pshow x+ b <- pshow $ f x+ return $ "forall " ++ x' ++ ". " ++ b++--------------------------------------------------------------------------------+-- Stage 0+--------------------------------------------------------------------------------++type Input = Const :+: TT :+: FF :+: Atom :+: Not :+: Or :+: And :+:+ Impl :+: Exists :+: Forall++foodFact :: Term Input TFormula+foodFact =+ (iExists $ \p -> iAtom "Person" [Place p] `iAnd`+ (iForall $ \f -> iAtom "Food" [Place f] `iImpl`+ iAtom "Eats" [Place p,Place f])) `iImpl`+ iNot (iExists $ \f -> iAtom "Food" [Place f] `iAnd`+ iNot (iExists $ \p -> iAtom "Person" [Place p] `iAnd`+ iAtom "Eats" [Place p,Place f]))++--------------------------------------------------------------------------------+-- Stage 1+--------------------------------------------------------------------------------++type Stage1 = Const :+: TT :+: FF :+: Atom :+: Not :+: Or :+: And :+:+ Exists :+: Forall++class ElimImp f where+ elimImpHom :: TermHom f Stage1++$(derive [liftSum] [''ElimImp])++instance (f :<: Stage1) => ElimImp f where+ elimImpHom = simpCxt . inj++instance ElimImp Impl where+ elimImpHom (Impl f1 f2) = iNot (Hole f1) `iOr` (Hole f2)++elimImp :: Term Input :-> Term Stage1+elimImp = appTermHom elimImpHom++foodFact1 :: Term Stage1 TFormula+foodFact1 = elimImp foodFact++--------------------------------------------------------------------------------+-- Stage 2+--------------------------------------------------------------------------------++type Stage2 = Const :+: TT :+: FF :+: Atom :+: NAtom :+: Or :+: And :+:+ Exists :+: Forall++class Dualize f where+ dualizeHom :: TermHom f Stage2++$(derive [liftSum] [''Dualize])++instance Dualize Const where+ dualizeHom (Const f t) = iConst f $ map Hole 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 $ map Hole t++instance Dualize NAtom where+ dualizeHom (NAtom p t) = iAtom p $ map Hole t++instance Dualize Or where+ dualizeHom (Or f1 f2) = Hole f1 `iAnd` Hole f2++instance Dualize And where+ dualizeHom (And f1 f2) = Hole f1 `iOr` Hole f2++instance Dualize Exists where+ dualizeHom (Exists f) = iForall (Hole . f)++instance Dualize Forall where+ dualizeHom (Forall f) = iExists (Hole . f)++dualize :: Term Stage2 :-> Term Stage2+dualize = appTermHom dualizeHom++class PushNot f where+ pushNotAlg :: Alg f (Term Stage2)++$(derive [liftSum] [''PushNot])++instance PushNot Const where+ pushNotAlg (Const f t) = iConst f t++instance PushNot TT where+ pushNotAlg TT = iTT++instance PushNot FF where+ pushNotAlg FF = iFF++instance PushNot Atom where+ pushNotAlg (Atom p t) = iAtom p t++instance PushNot Not where+ pushNotAlg (Not f) = dualize f++instance PushNot Or where+ pushNotAlg (Or f1 f2) = f1 `iOr` f2++instance PushNot And where+ pushNotAlg (And f1 f2) = f1 `iAnd` f2++instance PushNot Exists where+ pushNotAlg (Exists f) = iExists (f . Place)++instance PushNot Forall where+ pushNotAlg (Forall f) = iForall (f . Place)++pushNotInwards :: Term Stage1 :-> Term Stage2+pushNotInwards = cata pushNotAlg++foodFact2 :: Term Stage2 TFormula+foodFact2 = pushNotInwards foodFact1++--------------------------------------------------------------------------------+-- Stage 4+--------------------------------------------------------------------------------++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 = ReaderT [Term Stage4 TTerm] Supply++evalS :: S a -> [Term Stage4 TTerm] -> UniqueSupply -> a+evalS m env s = evalState (runReaderT m env) s++fresh :: S Int+fresh = do supply <- get+ let (uniq,rest) = getUnique supply+ put rest+ return uniq++freshes :: S UniqueSupply+freshes = do supply <- get+ let (l,r) = splitUniqueSupply supply+ put r+ return l++class Skolem f where+ skolemAlg :: AlgM' S f (Term Stage4)++$(derive [liftSum] [''Skolem])++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 f1 f2) = liftM2 iOr (getCompose f1) (getCompose f2)++instance Skolem And where+ skolemAlg (And f1 f2) = liftM2 iAnd (getCompose f1) (getCompose f2)++instance Skolem Forall where+ skolemAlg (Forall f) = do+ supply <- freshes+ xs <- ask+ return $ iForall $ \x -> evalS (getCompose $ f (Place x))+ (Place x : xs)+ supply++instance Skolem Exists where+ skolemAlg (Exists f) = do uniq <- fresh+ xs <- ask+ getCompose $ f (iConst ("Skol" ++ show uniq) xs)++skolemize :: Term Stage2 :-> Term Stage4+skolemize f = evalState (runReaderT (cataM' skolemAlg f) []) initialUniqueSupply++foodFact4 :: Term Stage4 TFormula+foodFact4 = skolemize foodFact2++--------------------------------------------------------------------------------+-- Stage 5+--------------------------------------------------------------------------------++type Stage5 = Const :+: Var :+: TT :+: FF :+: Atom :+: NAtom :+: Or :+: And++class Prenex f where+ prenexAlg :: AlgM' S f (Term Stage5)++$(derive [liftSum] [''Prenex])++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 f1 f2) = liftM2 iOr (getCompose f1) (getCompose f2)++instance Prenex And where+ prenexAlg (And f1 f2) = liftM2 iAnd (getCompose f1) (getCompose f2)++instance Prenex Forall where+ prenexAlg (Forall f) = do uniq <- fresh+ getCompose $ f (iVar ("x" ++ show uniq))++prenex :: Term Stage4 :-> Term Stage5+prenex f = evalState (runReaderT (cataM' prenexAlg f) []) initialUniqueSupply++foodFact5 :: Term Stage5 TFormula+foodFact5 = prenex foodFact4++--------------------------------------------------------------------------------+-- Stage 6+--------------------------------------------------------------------------------++type Literal = Term (Const :+: Var :+: Atom :+: NAtom)+newtype Clause i = Clause {unClause :: [Literal i]} -- implicit disjunction+newtype CNF i = CNF {unCNF :: [Clause i]} -- implicit conjunction++instance Show (Clause i) where+ show c = concat $ intersperse " or " $ map show $ unClause c++instance Show (CNF i) where+ show c = concat $ intersperse "\n" $ map show $ unCNF c++class ToCNF f where+ cnfAlg :: Alg f CNF++$(derive [liftSum] [''ToCNF])++instance ToCNF Const where+ cnfAlg (Const f t) = CNF [Clause [iConst f (map (head . unClause . head . unCNF) t)]]++instance ToCNF Var where+ cnfAlg (Var x) = CNF [Clause [iVar x]]++instance ToCNF TT where+ cnfAlg TT = CNF []++instance ToCNF FF where+ cnfAlg FF = CNF [Clause []]++instance ToCNF Atom where+ cnfAlg (Atom p t) = CNF [Clause [iAtom p (map (head . unClause . head . unCNF) t)]]++instance ToCNF NAtom where+ cnfAlg (NAtom p t) = CNF [Clause [iNAtom p (map (head . unClause . head . unCNF) t)]]++instance ToCNF And where+ cnfAlg (And f1 f2) = CNF $ unCNF f1 ++ unCNF f2++instance ToCNF Or where+ cnfAlg (Or f1 f2) = CNF [Clause (x ++ y) | Clause x <- unCNF f1, Clause y <- unCNF f2]++cnf :: Term Stage5 :-> CNF+cnf = cata cnfAlg++foodFact6 :: CNF TFormula+foodFact6 = cnf foodFact5++--------------------------------------------------------------------------------+-- Stage 7+--------------------------------------------------------------------------------++type T = Const :+: Var :+: Atom :+: NAtom+newtype IClause i = IClause ([Term T i], -- implicit conjunction+ [Term T i]) -- implicit disjunction+newtype INF i = INF [IClause i] -- implicit conjunction++instance Show (IClause i) where+ show (IClause (cs,ds)) =+ let cs' = concat $ intersperse " and " $ map show cs+ ds' = concat $ intersperse " or " $ map show ds+ in "(" ++ cs' ++ ") -> (" ++ ds' ++ ")"++instance Show (INF i) where+ show (INF fs) = concat $ intersperse "\n" $ map show fs++inf :: CNF TFormula -> INF TFormula+inf (CNF f) = INF $ map (toImpl . unClause) f+ where toImpl :: [Literal TFormula] -> IClause TFormula+ toImpl disj = IClause ([iAtom p t | NAtom p t <- mapMaybe proj1 disj],+ [inject t | t <- mapMaybe proj2 disj])+ proj1 :: NatM Maybe (Term T) (NAtom Any (Term T))+ proj1 = project+ proj2 :: NatM Maybe (Term T) (Atom Any (Term T))+ proj2 = project++foodFact7 :: INF TFormula+foodFact7 = inf foodFact6
+ examples/Examples/Param/DesugarEval.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances,+ TypeSynonymInstances, OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Param.DesugarEval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Expression Evaluation+--+-- The example illustrates how to compose a term homomorphism and an algebra,+-- exemplified via a desugaring term homomorphism and an evaluation algebra.+--+-- The example extends the example from 'Examples.Param.Eval'.+--+--------------------------------------------------------------------------------++module Examples.Param.DesugarEval where++import Data.Comp.Param hiding (Const)+import Data.Comp.Param.Show ()+import Data.Comp.Param.Derive+import Data.Comp.Param.Desugar++-- Signatures for values and operators+data Const a e = Const Int+data Lam a e = Lam (a -> e) -- Note: not e -> e+data App a e = App e e+data Op a e = Add e e | Mult e e+data Fun a e = Fun (e -> e) -- Note: not a -> e+data IfThenElse a e = IfThenElse e e e++-- Signature for syntactic sugar (negation, let expressions, Y combinator)+data Sug a e = Neg e | Let e (a -> e) | Fix++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op :+: IfThenElse+-- Signature for the simple expression language with syntactic sugar+type Sig' = Sug :+: Sig+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)+type Value = Const :+: Fun+-- Signature for ground values.+type GValue = Const++-- Derive boilerplate code using Template Haskell+$(derive [makeDifunctor, makeEqD, makeShowD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op, ''IfThenElse, ''Sug])+$(derive [makeDitraversable]+ [''Const, ''App, ''Op])+$(derive [smartConstructors] [''Fun])++instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, Difunctor f)+ => Desugar Sug f where+ desugHom' (Neg x) = iConst (-1) `iMult` x+ desugHom' (Let x y) = iLam y `iApp` x+ desugHom' Fix = iLam $ \f ->+ (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))+ `iApp`+ (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))++-- Term evaluation algebra+class Eval f v where+ evalAlg :: Alg f (Term v)++$(derive [liftSum] [''Eval])++-- Compose the evaluation algebra and the desugaring homomorphism to an algebra+eval :: Term Sig -> Term Value+eval = cata evalAlg++evalDesug :: Term Sig' -> Term Value+evalDesug = eval . desugar++instance (Const :<: v) => Eval Const v where+ evalAlg (Const n) = iConst n++instance (Const :<: v) => Eval Op v where+ evalAlg (Add x y) = iConst $ (projC x) + (projC y)+ evalAlg (Mult x y) = iConst $ (projC x) * (projC y)++instance (Fun :<: v) => Eval App v where+ evalAlg (App x y) = (projF x) y++instance (Fun :<: v) => Eval Lam v where+ evalAlg (Lam f) = iFun f++instance (Const :<: v) => Eval IfThenElse v where+ evalAlg (IfThenElse c v1 v2) = if projC c /= 0 then v1 else v2++projC :: (Const :<: v) => Term v -> Int+projC v = case project v of Just (Const n) -> n++projF :: (Fun :<: v) => Term v -> Term v -> Term v+projF v = case project v of Just (Fun f) -> f++-- |Evaluation of expressions to ground values.+evalG :: Term Sig' -> Maybe (Term GValue)+evalG = deepProject . evalDesug++-- Example: evalEx = Just (iConst 720)+evalEx :: Maybe (Term GValue)+evalEx = evalG $ fact `iApp` iConst 6++fact :: Term Sig'+fact = iFix `iApp`+ (iLam $ \f ->+ iLam $ \n ->+ iIfThenElse+ (Place n)+ (Place n `iMult` (Place f `iApp` (Place n `iAdd` iConst (-1))))+ (iConst 1))
+ examples/Examples/Param/DesugarPos.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances,+ TypeSynonymInstances, OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Param.DesugarPos+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Desugaring + Propagation of Annotations+--+-- The example illustrates how to compose a term homomorphism and an algebra,+-- exemplified via a desugaring term homomorphism and an evaluation algebra.+--+--------------------------------------------------------------------------------++module Examples.Param.DesugarPos where++import Data.Comp.Param hiding (Const)+import Data.Comp.Param.Show ()+import Data.Comp.Param.Derive+import Data.Comp.Param.Desugar++-- Signatures for values and operators+data Const a e = Const Int+data Lam a e = Lam (a -> e) -- Note: not e -> e+data App a e = App e e+data Op a e = Add e e | Mult e e++-- Signature for syntactic sugar (negation, let expressions, Y combinator)+data Sug a e = Neg e | Let e (a -> e) | Fix++-- Source position information (line number, column number)+data Pos = Pos Int Int+ deriving (Show, Eq)++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op+type SigP = Const :&: Pos :+: Lam :&: Pos :+: App :&: Pos :+: Op :&: Pos++-- Signature for the simple expression language, extended with syntactic sugar+type Sig' = Sug :+: Sug+type SigP' = Sug :&: Pos :+: SigP++-- Derive boilerplate code using Template Haskell+$(derive [makeDifunctor, makeEqD, makeShowD,+ smartConstructors, smartAConstructors]+ [''Const, ''Lam, ''App, ''Op, ''Sug])++instance (Op :<: f, Const :<: f, Lam :<: f, App :<: f, Difunctor f)+ => Desugar Sug f where+ desugHom' (Neg x) = iConst (-1) `iMult` x+ desugHom' (Let x y) = iLam y `iApp` x+ desugHom' Fix = iLam $ \f ->+ (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))+ `iApp`+ (iLam $ \x -> Place f `iApp` (Place x `iApp` Place x))++-- Example: desugPEx == iAApp (Pos 1 0)+-- (iALam (Pos 1 0) Place)+-- (iALam (Pos 1 1) $ \f ->+-- iAApp (Pos 1 1)+-- (iALam (Pos 1 1) $ \x ->+-- iAApp (Pos 1 1) (Place f) (iAApp (Pos 1 1) (Place x) (Place x)))+-- (iALam (Pos 1 1) $ \x ->+-- iAApp (Pos 1 1) (Place f) (iAApp (Pos 1 1) (Place x) (Place x))))+desugPEx :: Term SigP+desugPEx = desugarA (iALet (Pos 1 0) (iAFix (Pos 1 1)) Place :: Term SigP')
+ examples/Examples/Param/Eval.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Param.Eval+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Expression Evaluation+--+-- The example illustrates how to use parametric compositional data types to+-- implement a small expression language, with a language of values, and+-- an evaluation function mapping expressions to values. The example+-- demonstrates how (parametric) abstractions are mapped to general functions,+-- from values to values, and how it is possible to project a general value+-- (with functions) back into ground values, that can again be analysed.+--+--------------------------------------------------------------------------------++module Examples.Param.Eval where++import Data.Comp.Param hiding (Const)+import Data.Comp.Param.Show ()+import Data.Comp.Param.Derive++-- Signatures for values and operators+data Const a e = Const Int+data Lam a e = Lam (a -> e) -- Note: not e -> e+data App a e = App e e+data Op a e = Add e e | Mult e e+data Fun a e = Fun (e -> e) -- Note: not a -> e++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op+-- Signature for values. Note the use of 'Fun' rather than 'Lam' (!)+type Value = Const :+: Fun+-- Signature for ground values.+type GValue = Const++-- Derive boilerplate code using Template Haskell+$(derive [makeDifunctor, makeEqD, makeShowD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op])+$(derive [makeDitraversable]+ [''Const, ''App, ''Op])+$(derive [smartConstructors] [''Fun])++-- Term evaluation algebra+class Eval f v where+ evalAlg :: Alg f (Term v)++$(derive [liftSum] [''Eval])++-- Lift the evaluation algebra to a catamorphism+eval :: (Difunctor f, Eval f v) => Term f -> Term v+eval = cata evalAlg++instance (Const :<: v) => Eval Const v where+ evalAlg (Const n) = iConst n++instance (Const :<: v) => Eval Op v where+ evalAlg (Add x y) = iConst $ (projC x) + (projC y)+ evalAlg (Mult x y) = iConst $ (projC x) * (projC y)++instance (Fun :<: v) => Eval App v where+ evalAlg (App x y) = (projF x) y++instance (Fun :<: v) => Eval Lam v where+ evalAlg (Lam f) = iFun f++projC :: (Const :<: v) => Term v -> Int+projC v = case project v of Just (Const n) -> n++projF :: (Fun :<: v) => Term v -> Term v -> Term v+projF v = case project v of Just (Fun f) -> f++-- |Evaluation of expressions to ground values.+evalG :: Term Sig -> Maybe (Term GValue)+evalG = deepProject . (eval :: Term Sig -> Term Value)++-- Example: evalEx = Just (iConst 4)+evalEx :: Maybe (Term GValue)+evalEx = evalG $ (iLam $ \x -> Place x `iAdd` Place x) `iApp` iConst 2
+ examples/Examples/Param/EvalAlgM.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Param.EvalAlgM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Monadic Expression Evaluation without PHOAS+--+-- The example illustrates how to use parametric compositional data types to+-- implement a small expression language, with a sub language of values, and a+-- monadic evaluation function mapping expressions to values. The lack for PHOAS+-- means that -- unlike the example in 'Examples.Param.EvalM' -- a monadic+-- algebra can be used.+--+--------------------------------------------------------------------------------++module Examples.Param.EvalAlgM where++import Data.Comp.Param+import Data.Comp.Param.Show ()+import Data.Comp.Param.Ditraversable+import Data.Comp.Param.Derive+import Control.Monad (liftM)++-- Signature for values and operators+data Value a e = Const Int | Pair e e+data Op a e = Add e e | Mult e e | Fst e | Snd e++-- Signature for the simple expression language+type Sig = Op :+: Value++-- Derive boilerplate code using Template Haskell+$(derive [makeDifunctor, makeDitraversable,+ makeEqD, makeShowD, smartConstructors]+ [''Value, ''Op])++-- Monadic term evaluation algebra+class EvalM f v where+ evalAlgM :: AlgM Maybe f (Term v)++$(derive [liftSum] [''EvalM])++-- Lift the monadic evaluation algebra to a monadic catamorphism+evalM :: (Ditraversable f Maybe (Term v), EvalM f v) => Term f -> Maybe (Term v)+evalM = cataM evalAlgM++instance (Value :<: v) => EvalM Value v where+ evalAlgM (Const n) = return $ iConst n+ evalAlgM (Pair x y) = return $ iPair x y++instance (Value :<: v) => EvalM Op v where+ evalAlgM (Add x y) = do n1 <- projC x+ n2 <- projC y+ return $ iConst $ n1 + n2+ evalAlgM (Mult x y) = do n1 <- projC x+ n2 <- projC y+ return $ iConst $ n1 * n2+ evalAlgM (Fst v) = liftM fst $ projP v+ evalAlgM (Snd v) = liftM snd $ projP v++projC :: (Value :<: v) => Term v -> Maybe Int+projC v = case project v of+ Just (Const n) -> return n+ _ -> Nothing++projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v)+projP v = case project v of+ Just (Pair x y) -> return (x,y)+ _ -> Nothing++-- Example: evalMEx = Just (iConst 5)+evalMEx :: Maybe (Term Value)+evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)
+ examples/Examples/Param/EvalM.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Param.EvalM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Monadic Expression Evaluation+--+-- The example illustrates how to use parametric compositional data types to+-- implement a small expression language, with a language of values, and+-- a monadic evaluation function mapping expressions to values. The example+-- demonstrates how (parametric) abstractions are mapped to general functions,+-- from values to /monadic/ values, and how it is possible to project a general+-- value (with functions) back into ground values, that can again be analysed.+--+--------------------------------------------------------------------------------++module Examples.Param.EvalM where++import Data.Comp.Param hiding (Const)+import Data.Comp.Param.Show ()+import Data.Comp.Param.Derive+import Control.Monad ((<=<))++-- Signatures for values and operators+data Const a e = Const Int+data Lam a e = Lam (a -> e) -- Note: not e -> e+data App a e = App e e+data Op a e = Add e e | Mult e e+data FunM m a e = FunM (e -> m e) -- Note: not a -> m e++-- Signature for the simple expression language+type Sig = Const :+: Lam :+: App :+: Op+-- Signature for values. Note the use of 'FunM' rather than 'Lam' (!)+type Value = Const :+: FunM Maybe+-- Signature for ground values.+type GValue = Const++-- Derive boilerplate code using Template Haskell+$(derive [makeDifunctor, makeEqD, makeShowD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op])+$(derive [makeDitraversable]+ [''Const, ''App, ''Op])+$(derive [smartConstructors] [''FunM])++-- Term evaluation algebra. Note that we cannot use @AlgM Maybe f (Term v)@+-- because that would force @FunM@ to have the type @e -> e@ rather than+-- @e -> m e@. The latter is needed because the input to a @Lam@ (which is+-- evaluated to a @Fun@) will determine whether or not an error should be+-- returned. Example: @(\x -> x x) 42@ will produce an error because the+-- abstraction is applied to a non-functional, whereas @(\x -> x x)(\y -> y)@+-- will not.+class EvalM f v where+ evalAlgM :: Alg f (Maybe (Term v))++$(derive [liftSum] [''EvalM])++-- Lift the evaluation algebra to a catamorphism+evalM :: (Difunctor f, EvalM f v) => Term f -> Maybe (Term v)+evalM = cata evalAlgM++instance (Const :<: v) => EvalM Const v where+ evalAlgM (Const n) = return $ iConst n++instance (Const :<: v) => EvalM Op v where+ evalAlgM (Add mx my) = do x <- projC =<< mx+ y <- projC =<< my+ return $ iConst $ x + y+ evalAlgM (Mult mx my) = do x <- projC =<< mx+ y <- projC =<< my+ return $ iConst $ x * y++instance (FunM Maybe :<: v) => EvalM App v where+ evalAlgM (App mx my) = do f <- projF =<< mx+ f =<< my++instance (FunM Maybe :<: v) => EvalM Lam v where+ evalAlgM (Lam f) = return $ iFunM $ f . return++projC :: (Const :<: v) => Term v -> Maybe Int+projC v = do Const n <- project v+ return n++projF :: (FunM Maybe :<: v) => Term v -> Maybe (Term v -> Maybe (Term v))+projF v = do FunM f <- project v+ return f++-- |Evaluation of expressions to ground values.+evalMG :: Term Sig -> Maybe (Term GValue)+evalMG = deepProject <=< (evalM :: Term Sig -> Maybe (Term Value))++-- Example: evalEx = Just (iConst 12) (3 * (2 + 2) = 12)+evalMEx :: Maybe (Term GValue)+evalMEx = evalMG $ (iLam $ \x -> iLam $ \y ->+ Place y `iMult` (Place x `iAdd` Place x))+ `iApp` iConst 2 `iApp` iConst 3
+ examples/Examples/Param/Parsing.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell, TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, FlexibleContexts, UndecidableInstances,+ OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Examples.Param.Parsing+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- From Parse Tree to Parametric Higher-Order Abstract Syntax+--+-- The example illustrates how to convert a parse tree with explicit variables+-- into an AST which uses parametric higher-order abstract syntax instead. The+-- example shows how we can easily convert object language binders to Haskell+-- binders, without having to worry about capture avoidance.+--+--------------------------------------------------------------------------------++module Examples.Param.Parsing where++import Data.Comp.Param hiding (Const)+import Data.Comp.Param.Show ()+import Data.Comp.Param.Derive+import Data.Comp.Param.Ditraversable++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import Control.Monad.Reader++type VarId = String++-- Signatures for values and operators+data Const a e = Const Int+data Abs a e = Abs VarId e+data Var a e = Var VarId+data Lam a e = Lam (a -> e) -- Note: not e -> e+data App a e = App e e+data Op a e = Add e e | Mult e e++-- Signature for the simple expression language, parse tree+type Sig = Const :+: Abs :+: Var :+: App :+: Op+-- Signature for the simple expression language, PHOAS (Lam replaces Abs + Var)+type Sig' = Const :+: Lam :+: App :+: Op++-- Derive boilerplate code using Template Haskell+$(derive [makeDifunctor, makeDitraversable, makeEqD, makeShowD, smartConstructors]+ [''Const, ''Lam, ''App, ''Op, ''Abs, ''Var])++type TransM = Reader (Map VarId Any)++class PHOASTrans f g where+ transAlg :: Alg f (TransM (Term g))++$(derive [liftSum] [''PHOASTrans])++-- default translation+instance (f :<: g, Ditraversable f TransM Any) => PHOASTrans f g where+ transAlg x = liftM inject $ disequence $ dimap (return . Place) id x++instance (Lam :<: g) => PHOASTrans Abs g where+ transAlg (Abs x b) = do env <- ask+ return $ iLam $ \y -> runReader b (Map.insert x y env)++instance PHOASTrans Var g where+ transAlg (Var x) = liftM (Place . fromJust) $ asks $ Map.lookup x++trans :: Term Sig -> Term Sig'+trans x = runReader (cata transAlg x) Map.empty++-- Example: evalEx = iLam $ \a -> iApp (iLam $ \b -> iLam $ \c -> hole b) (hole a)+transEx :: Term Sig'+transEx = trans $ iAbs "y" $ (iAbs "x" $ iAbs "y" $ iVar "x") `iApp` (iVar "y")
src/Data/Comp.hs view
@@ -3,34 +3,21 @@ -- Module : Data.Comp -- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved -- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>+-- Maintainer : Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk> -- Stability : experimental -- Portability : non-portable (GHC Extensions) -- -- This module defines the infrastructure necessary to use -- /Compositional Data Types/. Compositional Data Types is an extension of -- Wouter Swierstra's Functional Pearl: /Data types a la carte/. Examples of--- usage are provided below.+-- usage are bundled with the package in the library @examples\/Examples@. -- -------------------------------------------------------------------------------- module Data.Comp(- -- * Examples- -- ** Pure Computations- -- $ex1-- -- ** Monadic Computations- -- $ex2-- -- ** Composing Term Homomorphisms and Algebras- -- $ex3-- -- ** Lifting Term Homomorphisms to Products- -- $ex4- module Data.Comp.Term , module Data.Comp.Algebra , module Data.Comp.Sum- , module Data.Comp.Product+ , module Data.Comp.Annotation , module Data.Comp.Equality , module Data.Comp.Ordering , module Data.Comp.Generic@@ -39,389 +26,7 @@ import Data.Comp.Term import Data.Comp.Algebra import Data.Comp.Sum-import Data.Comp.Product+import Data.Comp.Annotation import Data.Comp.Equality import Data.Comp.Ordering import Data.Comp.Generic--{- $ex1-The example below illustrates how to use 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: @TemplateHaskell@, @TypeOperators@,-@MultiParamTypeClasses@, @FlexibleInstances@, @FlexibleContexts@, and-@UndecidableInstances@.--> import Data.Comp-> import Data.Comp.Show ()-> import Data.Comp.Derive-> -> -- Signature for values and operators-> data Value e = Const Int | Pair e e-> data Op e = Add e e | Mult e e | Fst e | Snd e-> -> -- Signature for the simple expression language-> type Sig = Op :+: Value-> -> -- Derive boilerplate code using Template Haskell-> $(derive [instanceFunctor, instanceShowF, 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 :: (Functor 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-> projC v = let Just (Const n) = project v in n-> -> projP :: (Value :<: v) => Term v -> (Term v, Term v)-> projP v = let Just (Pair x y) = project v in (x,y)-> -> -- Example: evalEx = iConst 5-> evalEx :: Term Value-> evalEx = eval ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)--}--{- $ex2-The example below illustrates how to use compositional data types to 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: @TemplateHaskell@,-@TypeOperators@, @MultiParamTypeClasses@, @FlexibleInstances@,-@FlexibleContexts@, and @UndecidableInstances@.--> import Data.Comp-> import Data.Comp.Derive-> import Control.Monad (liftM)-> -> -- Signature for values and operators-> data Value e = Const Int | Pair e e-> data Op e = Add e e | Mult e e | Fst e | Snd e-> -> -- Signature for the simple expression language-> type Sig = Op :+: Value-> -> -- Derive boilerplate code using Template Haskell-> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,-> instanceEqF, instanceShowF, 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-> -> -- Lift the monadic evaluation algebra to a monadic catamorphism-> evalM :: (Traversable f, EvalM f v) => Term f -> Maybe (Term v)-> 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-> return $ iConst $ n1 + n2-> evalAlgM (Mult x y) = do n1 <- projC x-> n2 <- projC y-> return $ iConst $ n1 * n2-> evalAlgM (Fst v) = liftM fst $ projP v-> evalAlgM (Snd v) = liftM snd $ projP v-> -> projC :: (Value :<: v) => Term v -> Maybe Int-> projC v = case project v of-> Just (Const n) -> return n-> _ -> Nothing-> -> projP :: (Value :<: v) => Term v -> Maybe (Term v, Term v)-> projP v = case project v of-> Just (Pair x y) -> return (x,y)-> _ -> Nothing-> -> -- Example: evalMEx = Just (iConst 5)-> evalMEx :: Maybe (Term Value)-> evalMEx = evalM ((iConst 1) `iAdd` (iConst 2 `iMult` iConst 2) :: Term Sig)--}--{- $ex3-The example below illustrates how to compose a term homomorphism and an algebra,-exemplified via a desugaring term homomorphism and an evaluation algebra.--The following language extensions are needed in order to run the example:-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,-@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.--> import Data.Comp-> import Data.Comp.Show ()-> import Data.Comp.Derive-> -> -- Signature for values, operators, and syntactic sugar-> data Value e = Const Int | Pair e e-> data Op e = Add e e | Mult e e | Fst e | Snd e-> data Sugar e = Neg e | Swap e->-> -- 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-> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,-> instanceEqF, instanceShowF, smartConstructors]-> [''Value, ''Op, ''Sugar])-> -> -- Term homomorphism for desugaring of terms-> class (Functor f, Functor g) => Desugar f g where-> desugHom :: TermHom f g-> desugHom = desugHom' . fmap 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, Functor v) => Desugar Value v where-> desugHom = simpCxt . inj-> -> instance (Op :<: v, Functor v) => Desugar Op v where-> desugHom = simpCxt . inj-> -> instance (Op :<: v, Value :<: v, Functor 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-> projC v = let Just (Const n) = project v in n-> -> projP :: (Value :<: v) => Term v -> (Term v, Term v)-> projP v = let Just (Pair x y) = project v in (x,y)->-> -- Compose the evaluation algebra and the desugaring homomorphism to an-> -- algebra-> eval :: Term Sig' -> Term Value-> eval = cata (evalAlg `compAlg` (desugHom :: TermHom Sig' Sig))-> -> -- Example: evalEx = iPair (iConst 2) (iConst 1)-> evalEx :: Term Value-> evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2)--}--{- $ex4-The example below illustrates how to lift a term homomorphism to products,-exemplified via a desugaring term homomorphism lifted to terms annotated with-source position information.--The following language extensions are needed in order to run the example:-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,-@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.--> import Data.Comp-> import Data.Comp.Show ()-> import Data.Comp.Derive-> -> -- Signature for values, operators, and syntactic sugar-> data Value e = Const Int | Pair e e-> data Op e = Add e e | Mult e e | Fst e | Snd e-> data Sugar e = Neg e | Swap e->-> -- 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-> $(derive [instanceFunctor, instanceTraversable, instanceFoldable,-> instanceEqF, instanceShowF, smartConstructors]-> [''Value, ''Op, ''Sugar])-> -> -- Term homomorphism for desugaring of terms-> class (Functor f, Functor g) => Desugar f g where-> desugHom :: TermHom f g-> desugHom = desugHom' . fmap 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, Functor v) => Desugar Value v where-> desugHom = simpCxt . inj-> -> instance (Op :<: v, Functor v) => Desugar Op v where-> desugHom = simpCxt . inj-> -> instance (Op :<: v, Value :<: v, Functor 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 = appTermHom desugHom->-> -- Example: desugEx = iPair (iConst 2) (iConst 1)-> desugEx :: Term Sig-> desugEx = desug $ iSwap $ iPair (iConst 1) (iConst 2)->-> -- Lift desugaring to terms annotated with source positions-> desugP :: Term SigP' -> Term SigP-> desugP = appTermHom (productTermHom desugHom)->-> iSwapP :: (DistProd f p f', Sugar :<: f) => p -> Term f' -> Term f'-> iSwapP p x = Term (injectP p $ inj $ Swap x)->-> iConstP :: (DistProd f p f', Value :<: f) => p -> Int -> Term f'-> iConstP p x = Term (injectP p $ inj $ Const x)->-> iPairP :: (DistProd f p f', Value :<: f) => p -> Term f' -> Term f' -> Term f'-> iPairP p x y = Term (injectP p $ inj $ Pair x y)->-> iFstP :: (DistProd f p f', Op :<: f) => p -> Term f' -> Term f'-> iFstP p x = Term (injectP p $ inj $ Fst x)->-> iSndP :: (DistProd f p f', Op :<: f) => p -> Term f' -> Term f'-> iSndP p x = Term (injectP p $ inj $ Snd x)->-> -- Example: desugPEx = iPairP (Pos 1 0)-> -- (iSndP (Pos 1 0) (iPairP (Pos 1 1)-> -- (iConstP (Pos 1 2) 1)-> -- (iConstP (Pos 1 3) 2)))-> -- (iFstP (Pos 1 0) (iPairP (Pos 1 1)-> -- (iConstP (Pos 1 2) 1)-> -- (iConstP (Pos 1 3) 2)))-> desugPEx :: Term SigP-> desugPEx = desugP $ iSwapP (Pos 1 0) (iPairP (Pos 1 1) (iConstP (Pos 1 2) 1)-> (iConstP (Pos 1 3) 2))--}--{- $ex5-The example below illustrates how to use Higher-Order Abstract Syntax (HOAS)-with compositional data types.--The following language extensions are needed in order to run the example:-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,-@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@.--> import Data.Comp-> import Data.Comp.Show ()-> import Data.Comp.Derive-> -> -- Signature for values, operators, lambda functions, and applications-> data Value e = Const Int | Pair e e-> data Op e = Add e e | Mult e e | Fst e | Snd e-> data Lam e = Lam (e -> e)-> data App e = App e e-> -> -- Signature for the extended expression language-> type Val = Lam :+: Value-> type Sig = App :+: Op :+: Val->-> -- Derive boilerplate code using Template Haskell-> $(derive [instanceExpFunctor, smartConstructors]-> [''Value, ''Op, ''Lam, ''App])-> $(derive [instanceFunctor, instanceFoldable,-> instanceTraversable, instanceShowF] [''Value])-> -> -- 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->-> instance (Lam :<: v) => Eval Lam v where-> evalAlg = inject-> -> instance (Lam :<: v) => Eval App v where-> evalAlg (App x y) = (projL x) y-> -> projC :: (Value :<: v) => Term v -> Int-> projC v = let Just (Const n) = project v in n-> -> projP :: (Value :<: v) => Term v -> (Term v, Term v)-> projP v = let Just (Pair x y) = project v in (x,y)->-> projL :: (Lam :<: v) => Term v -> Term v -> Term v-> projL v = let Just (Lam f) = project v in f->-> -- Lift the evaluation algebra to a catamorphism. Note the use of 'cataE'-> -- instead of 'cata'.-> eval :: (ExpFunctor f, Eval f v) => Term f -> Term v-> eval = cataE evalAlg->-> -- Example: evalEx = Just (iConst 3). Note that we need to project the value-> -- to a value without HOAS in order to print it with 'showF'.-> evalEx :: Maybe (Term Value)-> evalEx = deepProject' $ (eval e :: Term Val)-> where e :: Term Sig-> e = (iLam $ \x -> x) `iApp` (iConst 1 `iAdd` iConst 2)--}
src/Data/Comp/Algebra.hs view
@@ -34,9 +34,14 @@ SigFun, TermHom, appTermHom,+ appTermHom', compTermHom, appSigFun,+ appSigFun', compSigFun,+ compSigFunTermHom,+ compTermHomSigFun,+ compAlgSigFun, termHom, compAlg, compCoalg,@@ -46,17 +51,22 @@ CxtFunM, SigFunM, TermHomM,- SigFunM',- TermHomM',+ SigFunMD,+ TermHomMD, sigFunM, termHom', appTermHomM,+ appTermHomM', termHomM,- termHomM',+ termHomMD, appSigFunM, appSigFunM',+ appSigFunMD, compTermHomM, compSigFunM,+ compSigFunTermHomM,+ compTermHomSigFunM,+ compAlgSigFunM, compAlgM, compAlgM', @@ -193,17 +203,21 @@ {-| This type represents a term homomorphism. -} type TermHom f g = SigFun f (Context g) -{-| Apply a term homomorphism recursively to a term/context. -}-appTermHom :: (Traversable f, Functor g) => TermHom f g -> CxtFun f g-{-# INLINE [1] appTermHom #-}--- Constraint Traversable f is not essential and can be replaced by--- Functor f. It is, however, needed for the shortcut-fusion rules to--- work.-appTermHom = appTermHom'- {-| This function applies the given term homomorphism to a term/context. -}-appTermHom' :: forall f g . (Functor f, Functor g) => TermHom f g -> CxtFun f g+appTermHom :: forall f g . (Functor f, Functor g) => TermHom f g -> CxtFun f g+{-# NOINLINE [1] appTermHom #-}+-- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type+-- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -> Cxt h f b -> Cxt h g b+-- would achieve the same. The given type is chosen for clarity.+appTermHom f = run where+ run :: CxtFun f g+ run (Hole x) = Hole x+ run (Term t) = appCxt (f (fmap run t))++-- | Apply a term homomorphism recursively to a term/context. This is+-- a top-down variant of 'appTermHom'.+appTermHom' :: forall f g . (Functor g) => TermHom f g -> CxtFun f g {-# NOINLINE [1] appTermHom' #-} -- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -> Cxt h f b -> Cxt h g b@@ -211,7 +225,7 @@ appTermHom' f = run where run :: CxtFun f g run (Hole x) = Hole x- run (Term t) = appCxt (f (fmap run t))+ run (Term t) = appCxt (fmap run (f t)) {-| Compose two term homomorphisms. -} compTermHom :: (Functor g, Functor h) => TermHom g h -> TermHom f g -> TermHom f h@@ -219,7 +233,7 @@ -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -- -> (a -> Cxt h f b) -> a -> Cxt h g b -- would achieve the same. The given type is chosen for clarity.-compTermHom f g = appTermHom' f . g+compTermHom f g = appTermHom f . g {-| Compose an algebra with a term homomorphism to get a new algebra. -} compAlg :: (Functor g) => Alg g a -> TermHom f g -> Alg f a@@ -233,22 +247,47 @@ -} compCVCoalg :: (Functor f, Functor g) => TermHom f g -> CVCoalg' f a -> CVCoalg' g a-compCVCoalg hom coa = appTermHom' hom . coa+compCVCoalg hom coa = appTermHom hom . coa {-| This function applies a signature function to the given context. -}-appSigFun :: (Functor f, Functor g) => SigFun f g -> CxtFun f g-appSigFun f = appTermHom' $ termHom f+appSigFun :: (Functor f) => SigFun f g -> CxtFun f g+{-# NOINLINE [1] appSigFun #-}+appSigFun f = run+ where run (Term t) = Term $ f $ fmap run t+ run (Hole x) = Hole x+-- implementation via term homomorphisms:+-- appSigFun f = appTermHom_ $ termHom f +-- | This function applies a signature function to the given+-- context. This is a top-down variant of 'appSigFun'.+appSigFun' :: (Functor g) => SigFun f g -> CxtFun f g+{-# NOINLINE [1] appSigFun' #-}+appSigFun' f = run+ where run (Term t) = Term $ fmap run $ f t+ 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 signature function with a term+-- homomorphism.+compSigFunTermHom :: (Functor g) => SigFun g h -> TermHom f g -> TermHom f h+compSigFunTermHom f g = appSigFun f . g -{-| Lifts the given signature function to the canonical term homomorphism.--}+-- | This function composes a term homomorphism with a signature function.+compTermHomSigFun :: TermHom g h -> SigFun f g -> TermHom f h+compTermHomSigFun f g = f . g +-- | This function composes an algebra with a signature function.+compAlgSigFun :: Alg g a -> SigFun f g -> Alg f a+compAlgSigFun f g = f . g+++-- | Lifts the given signature function to the canonical term+-- homomorphism. termHom :: (Functor g) => SigFun f g -> TermHom f g termHom f = simpCxt . f @@ -263,14 +302,14 @@ {-| This type represents a monadic signature function. It is similar to 'SigFunM' but has monadic values also in the domain. -}-type SigFunM' m f g = forall a. f (m a) -> m (g a)+type SigFunMD m f g = forall a. f (m a) -> m (g a) {-| This type represents a monadic term homomorphism. -} type TermHomM m f g = SigFunM m f (Context g) {-| This type represents a monadic term homomorphism. It is similar to 'TermHomM' but has monadic values also in the domain. -}-type TermHomM' m f g = SigFunM' m f (Context g)+type TermHomMD m f g = SigFunMD m f (Context g) {-| Lift the given signature function to a monadic signature function. Note that@@ -283,9 +322,10 @@ termHom' :: (Functor f, Functor g, Monad m) => SigFunM m f g -> TermHomM m f g termHom' f = liftM (Term . fmap Hole) . f + {-| Lift the given signature function to a monadic term homomorphism. -}-termHomM :: (Functor g, Monad m) => SigFun f g -> TermHomM m f g-termHomM f = sigFunM $ termHom f+termHomM :: (Functor g, Monad m) => SigFunM m f g -> TermHomM m f g+termHomM f = liftM simpCxt . f {-| Apply a monadic term homomorphism recursively to a term/context. -}@@ -295,40 +335,76 @@ appTermHomM 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 =<< mapM run t)+ run (Term t) = liftM appCxt . f =<< mapM run t +-- | Apply a monadic term homomorphism recursively to a+-- term/context. This a top-down variant of 'appTermHomM'.+appTermHomM' :: forall f g m . (Traversable g, Monad m)+ => TermHomM m f g -> CxtFunM m f g+{-# NOINLINE [1] appTermHomM' #-}+appTermHomM' f = run+ where run :: Cxt h f a -> m (Cxt h g a)+ run (Hole x) = return (Hole x)+ run (Term t) = liftM appCxt . mapM run =<< f t+ {-| This function constructs the unique monadic homomorphism from the initial term algebra to the given term algebra. -}-termHomM' :: forall f g m . (Traversable f, Functor g, Monad m)- => TermHomM' m f g -> CxtFunM m f g-termHomM' f = run +termHomMD :: forall f g m . (Traversable f, Functor g, Monad m)+ => TermHomMD m f g -> CxtFunM m f g+termHomMD 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)) {-| This function applies a monadic signature function to the given context. -}-appSigFunM :: (Traversable f, Functor g, Monad m) => SigFunM m f g -> CxtFunM m f g-appSigFunM f = appTermHomM $ termHom' f+appSigFunM :: (Traversable f, Monad m) => SigFunM m f g -> CxtFunM m f g+{-# NOINLINE [1] appSigFunM #-}+appSigFunM f = run+ where run (Term t) = liftM Term . f =<< mapM run t+ run (Hole x) = return (Hole x)+-- implementation via term homomorphisms+-- appSigFunM f = appTermHomM $ termHom' f +++-- | This function applies a monadic signature function to the given+-- context. This is a top-down variant of 'appSigFunM'.+appSigFunM' :: (Traversable g, Monad m) => SigFunM m f g -> CxtFunM m f g+{-# NOINLINE [1] appSigFunM' #-}+appSigFunM' f = run+ where run (Term t) = liftM Term . mapM run =<< f t+ run (Hole x) = return (Hole x)+ {-| This function applies a signature function to the given context. -}-appSigFunM' :: forall f g m . (Traversable f, Functor g, Monad m)- => SigFunM' m f g -> CxtFunM m f g-appSigFunM' f = run +appSigFunMD :: forall f g m . (Traversable f, Functor g, Monad m)+ => SigFunMD m f g -> CxtFunM m f g+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)) {-| Compose two monadic term homomorphisms. -} compTermHomM :: (Traversable g, Functor h, Monad m)- => TermHomM m g h -> TermHomM m f g -> TermHomM m f h-compTermHomM f g = appTermHomM f <=< g+ => TermHomM m g h -> TermHomM m f g -> TermHomM m f h+compTermHomM f g = appTermHomM f <=< g +{-| Compose two monadic term homomorphisms. -}+compTermHomM' :: (Traversable h, Monad m)+ => TermHomM m g h -> TermHomM m f g -> TermHomM m f h+compTermHomM' f g = appTermHomM' f <=< g++{-| Compose two monadic term homomorphisms. -}+compTermHomM_ :: (Functor h, Functor g, Monad m)+ => TermHom g h -> TermHomM m f g -> TermHomM m f h+compTermHomM_ f g = liftM (appTermHom 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 -> TermHomM m f g -> AlgM m f a compAlgM alg talg = cataM' alg <=< talg + {-| Compose a monadic algebra with a term homomorphism to get a new monadic algebra. -} compAlgM' :: (Traversable g, Monad m) => AlgM m g a -> TermHom f g -> AlgM m f a@@ -337,8 +413,27 @@ {-| 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+compSigFunM f g = f <=< g +compSigFunTermHomM :: (Traversable g, Functor h, Monad m)+ => SigFunM m g h -> TermHomM m f g -> TermHomM m f h+compSigFunTermHomM f g = appSigFunM f <=< g+++{-| Compose two monadic term homomorphisms. -}+compSigFunTermHomM' :: (Traversable h, Monad m)+ => SigFunM m g h -> TermHomM m f g -> TermHomM m f h+compSigFunTermHomM' f g = appSigFunM' f <=< g++{-| This function composes two monadic signature functions. -}+compTermHomSigFunM :: (Monad m) => TermHomM m g h -> SigFunM m f g -> TermHomM m f h+compTermHomSigFunM f g = f <=< g+++{-| This function composes two monadic signature functions. -}+compAlgSigFunM :: (Monad m) => AlgM m g a -> SigFunM m f g -> AlgM m f a+compAlgSigFunM f g = f <=< g+ ---------------- -- Coalgebras -- ----------------@@ -449,26 +544,25 @@ type CVAlg f a f' = f (Term f') -> a --- | This function applies 'projectP' at the tip of the term.--projectTip :: (DistProd f a f') => Term f' -> (f (Term f'), a)-projectTip (Term v) = projectP v+-- | This function applies 'projectA' at the tip of the term.+projectTip :: (DistAnn f a f') => Term f' -> (f (Term f'), a)+projectTip (Term v) = projectA v {-| Construct a histomorphism from the given cv-algebra. -}-histo :: (Functor f,DistProd f a f') => CVAlg f a f' -> Term f -> a+histo :: (Functor f,DistAnn f a f') => CVAlg f a f' -> Term f -> a histo alg = snd . projectTip . cata run- where run v = Term $ injectP (alg v) v+ where run v = Term $ injectA (alg v) v {-| This type represents a monadic cv-algebra over a functor @f@ and carrier @a@. -} type CVAlgM m f a f' = f (Term f') -> m a {-| Construct a monadic histomorphism from the given monadic cv-algebra. -}-histoM :: (Traversable f, Monad m, DistProd f a f') =>+histoM :: (Traversable f, Monad m, DistAnn f a f') => CVAlgM m f a f' -> Term f -> m a histoM alg = liftM (snd . projectTip) . cataM run where run v = do r <- alg v- return $ Term $ injectP r v+ return $ Term $ injectA r v ----------------------------------- -- CV-Coalgebras & Futumorphisms --@@ -507,6 +601,67 @@ run x = appCxt $ fmap run (coa x) +-------------------------------------------+-- functions only used for rewrite rules --+-------------------------------------------+++appAlgTermHom :: forall f g d . (Functor g) => Alg g d -> TermHom f g -> Term f -> d+appAlgTermHom alg hom = run where+ run :: Term f -> d+ run (Term t) = run' $ hom t+ run' :: Context g (Term f) -> d+ run' (Term t) = alg $ fmap run' t+ run' (Hole x) = run x+++-- | This function applies a signature function after a term homomorphism.+appSigFunTermHom :: forall f g h. (Functor g)+ => SigFun g h -> TermHom f g -> CxtFun f h+{-# NOINLINE [1] appSigFunTermHom #-}+appSigFunTermHom f g = run where+ run :: CxtFun f h+ run (Term t) = run' $ g $ t+ run (Hole h) = Hole h+ run' :: Context g (Cxt h' f b) -> Cxt h' h b+ run' (Term t) = Term $ f $ fmap run' t+ run' (Hole h) = run h++-- | This function applies the given algebra bottom-up while applying+-- the given term homomorphism top-down. Thereby we have no+-- requirements on the source signature @f@.+appAlgTermHomM :: forall m f g a. (Traversable g, Monad m)+ => AlgM m g a -> TermHomM m f g -> Term f -> m a+appAlgTermHomM alg hom = run+ where run :: Term f -> m a+ run (Term t) = hom t >>= mapM run >>= run'+ run' :: (Context g a) -> m a+ run' (Term t) = mapM run' t >>= alg+ run' (Hole x) = return x+++appTermHomTermHomM :: forall m f g h . (Monad m, Traversable g, Functor h)+ => TermHomM m g h -> TermHomM m f g -> CxtFunM m f h+appTermHomTermHomM f g = run where+ run :: CxtFunM m f h+ run (Term t) = run' =<< g t+ run (Hole h) = return $ Hole h+ run' :: Context g (Cxt h' f b) -> m (Cxt h' h b)+ run' (Term t) = liftM appCxt $ f =<< mapM run' t+ run' (Hole h) = run h+++appSigFunTermHomM :: forall m f g h . (Traversable g, Monad m)+ => SigFunM m g h -> TermHomM m f g -> CxtFunM m f h+appSigFunTermHomM f g = run where+ run :: CxtFunM m f h+ run (Term t) = run' =<< g t+ run (Hole h) = return $ Hole h+ run' :: Context g (Cxt h' f b) -> m (Cxt h' h b)+ run' (Term t) = liftM Term $ f =<< mapM run' t+ run' (Hole h) = run h++ ------------------- -- rewrite rules -- -------------------@@ -516,19 +671,256 @@ "cata/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) x. cata a (appTermHom h x) = cata (compAlg a h) x; + "cata/appTermHom'" forall (a :: Alg g d) (h :: TermHom f g) x.+ cata a (appTermHom' h x) = appAlgTermHom 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) = appAlgTermHom a (termHom h) x;++ "cata/appSigFunTermHom" forall (f :: Alg f3 d) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ cata f (appSigFunTermHom g h x) = appAlgTermHom (compAlgSigFun f g) h x;++ "appAlgTermHom/appTermHom" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appTermHom f x) = cata (compAlg a (compTermHom h f)) x;++ "appAlgTermHom/appTermHom'" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appTermHom' f x) = appAlgTermHom a (compTermHom h f) x;++ "appAlgTermHom/appSigFun" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appSigFun f x) = cata (compAlg a (compTermHomSigFun h f)) x;++ "appAlgTermHom/appSigFun'" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appSigFun' f x) = appAlgTermHom a (compTermHomSigFun h f) x;++ "appAlgTermHom/appSigFunTermHom" forall (a :: Alg i d) (f :: TermHom f g) (g :: SigFun g h)+ (h :: TermHom h i) x.+ appAlgTermHom a h (appSigFunTermHom g f x)+ = appAlgTermHom a (compTermHom (compTermHomSigFun h g) f) x;+ "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x. appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;++ "appTermHom'/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom' a (appTermHom' h x) = appTermHom' (compTermHom a h) x;++ "appTermHom'/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom' a (appTermHom h x) = appTermHom (compTermHom a h) x;++ "appTermHom/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom a (appTermHom' h x) = appTermHom' (compTermHom 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) = appSigFunTermHom f (termHom g) x;++ "appSigFun'/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.+ appSigFun' f (appSigFun g x) = appSigFun (compSigFun f g) x;++ "appTermHom/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;++ "appTermHom/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom f (appSigFun' g x) = appTermHom' (compTermHomSigFun f g) x;++ "appTermHom'/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom' f (appSigFun' g x) = appTermHom' (compTermHomSigFun f g) x;++ "appTermHom'/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom' f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;+ + "appSigFun/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun f (appTermHom g x) = appSigFunTermHom f g x;++ "appSigFun'/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun' f (appTermHom' g x) = appTermHom' (compSigFunTermHom f g) x;++ "appSigFun/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun f (appTermHom' g x) = appSigFunTermHom f g x;++ "appSigFun'/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun' f (appTermHom g x) = appTermHom (compSigFunTermHom f g) x;+ + "appSigFunTermHom/appSigFun" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: SigFun f1 f2) x.+ appSigFunTermHom f g (appSigFun h x)+ = appSigFunTermHom f (compTermHomSigFun g h) x;++ "appSigFunTermHom/appSigFun'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: SigFun f1 f2) x.+ appSigFunTermHom f g (appSigFun' h x)+ = appSigFunTermHom f (compTermHomSigFun g h) x;++ "appSigFunTermHom/appTermHom" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFunTermHom f g (appTermHom h x)+ = appSigFunTermHom f (compTermHom g h) x;++ "appSigFunTermHom/appTermHom'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFunTermHom f g (appTermHom' h x)+ = appSigFunTermHom f (compTermHom g h) x;++ "appSigFun/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFun f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;++ "appSigFun'/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFun' f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;++ "appTermHom/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appTermHom f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;++ "appTermHom'/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appTermHom' f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;++ "appSigFunTermHom/appSigFunTermHom" forall (f1 :: SigFun f4 f5) (f2 :: TermHom f3 f4)+ (f3 :: SigFun f2 f3) (f4 :: TermHom f1 f2) x.+ appSigFunTermHom f1 f2 (appSigFunTermHom f3 f4 x)+ = appSigFunTermHom f1 (compTermHom (compTermHomSigFun f2 f3) f4) x; #-} {-# RULES - "cataM/appTermHomM" forall (a :: AlgM m g d) (h :: TermHomM m f g) x.- appTermHomM h x >>= cataM a = cataM (compAlgM a h) x;+ "cataM/appTermHomM" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= cataM a = appAlgTermHomM a h x; + "cataM/appTermHomM'" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= cataM a = appAlgTermHomM a h x;++ "cataM/appSigFunM" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.+ appSigFunM h x >>= cataM a = appAlgTermHomM a (termHomM h) x;++ "cataM/appSigFunM'" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= cataM a = appAlgTermHomM a (termHomM h) x;+ "cataM/appTermHom" forall (a :: AlgM m g d) (h :: TermHom f g) x.- cataM a (appTermHom h x) = cataM (compAlgM' a h) x;+ cataM a (appTermHom h x) = appAlgTermHomM a (sigFunM h) x; - "appTermHomM/appTermHomM" forall (a :: TermHomM m g h) (h :: TermHomM m f g) x.- appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;+ "cataM/appTermHom'" forall (a :: AlgM m g d) (h :: TermHom f g) x.+ cataM a (appTermHom' h x) = appAlgTermHomM a (sigFunM h) x;++ "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.+ cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;++ "cataM/appSigFun'" forall (a :: AlgM m g d) (h :: SigFun f g) x.+ cataM a (appSigFun' h x) = appAlgTermHomM a (sigFunM $ termHom h) x;++ "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.+ cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;++ "cataM/appSigFunTermHom" forall (a :: AlgM m h d) (g :: SigFun g h) (f :: TermHom f g) x.+ cataM a (appSigFunTermHom g f x) = appAlgTermHomM a (sigFunM $ compSigFunTermHom g f) x;++ "appTermHomM/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;++ "appTermHomM/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM h x >>= appTermHomM a = appTermHomM (compTermHomSigFunM a h) x;++ "appTermHomM/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appTermHomM a = appTermHomTermHomM a h x;++ "appTermHomM/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= appTermHomM a = appTermHomTermHomM a (termHomM h) x;++ "appTermHomM'/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;++ "appTermHomM'/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;++ "appTermHomM'/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;++ "appTermHomM'/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;++ "appTermHomM/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM a (appTermHom h x) = appTermHomTermHomM a (sigFunM h) x;++ "appTermHomM/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM a (appSigFun h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;++ "appTermHomM'/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM' a (appTermHom h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;++ "appTermHomM'/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM' a (appSigFun h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;++ "appTermHomM/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM a (appTermHom' h x) = appTermHomTermHomM a (sigFunM h) x;++ "appTermHomM/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM a (appSigFun' h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;++ "appTermHomM'/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM' a (appTermHom' h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;++ "appTermHomM'/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM' a (appSigFun' h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;++ "appSigFunM/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appSigFunM a = appSigFunTermHomM 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/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appSigFunM a = appSigFunTermHomM a h x;++ "appSigFunM/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= appSigFunM a = appSigFunTermHomM a (termHomM h) x;++ "appSigFunM'/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' 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'/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' 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/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM a (appTermHom h x) = appSigFunTermHomM a (sigFunM h) x;++ "appSigFunM/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.+ appSigFunM a (appSigFun h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;++ "appSigFunM'/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM' a (appTermHom h x) = appTermHomM' (compSigFunTermHomM' 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/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM a (appTermHom' h x) = appSigFunTermHomM a (sigFunM h) x;++ "appSigFunM/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.+ appSigFunM a (appSigFun' h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;++ "appSigFunM'/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM' a (appTermHom' h x) = appTermHomM' (compSigFunTermHomM' 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;+++ "appTermHom/appTermHomM" forall (a :: TermHom g h) (h :: TermHomM m f g) x.+ appTermHomM h x >>= (return . appTermHom a) = appTermHomM (compTermHomM_ a h) x; #-} {-# RULES
+ src/Data/Comp/Annotation.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,+ UndecidableInstances, RankNTypes, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Annotation+-- Copyright : (c) 2010-2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines annotations on signatures.+--+--------------------------------------------------------------------------------++module Data.Comp.Annotation+ (+ (:&:) (..),+ (:*:) (..),+ DistAnn (..),+ RemA (..),+ liftA,+ liftA',+ stripA,+ propAnn,+ propAnnM,+ ann,+ project'+ ) where++import Data.Comp.Term+import Data.Comp.Sum+import Data.Comp.Ops+import Data.Comp.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 -> t) -> s a -> 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, Functor s')+ => (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) + => TermHom f g -> TermHom 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', Functor g, Monad m) + => TermHomM m f g -> TermHomM 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, 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' :: (RemA f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))+project' v = liftM remA $ project v
src/Data/Comp/Arbitrary.hs view
@@ -20,7 +20,7 @@ import Test.QuickCheck import Data.Comp.Term import Data.Comp.Sum-import Data.Comp.Product+import Data.Comp.Ops import Data.Comp.Derive.Utils import Data.Comp.Derive import Control.Applicative@@ -31,8 +31,6 @@ instance (ArbitraryF f) => Arbitrary (Term f) where arbitrary = Term <$> arbitraryF shrink (Term expr) = map Term $ shrinkF expr- - instance (ArbitraryF f, Arbitrary p) => ArbitraryF (f :&: p) where arbitraryF' = map addP arbitraryF'@@ -68,4 +66,4 @@ shrinkF (Inr val) = map Inr (shrinkF val) -$(derive [instanceArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10)+$(derive [makeArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10)
− src/Data/Comp/Automata.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE RankNTypes #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Automata--- Copyright : (c) 2010-2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ This module defines tree automata based on compositional data types.--------------------------------------------------------------------------------------module Data.Comp.Automata where--import Data.Comp-import Data.Maybe-import Data.Traversable-import Control.Monad---{-| This type represents transition functions of deterministic-bottom-up tree acceptors (DUTAs). -}--type DUTATrans f q = Alg f q--{-| This data type represents deterministic bottom-up tree acceptors (DUTAs).--}-data DUTA f q = DUTA {- dutaTrans :: DUTATrans f q,- dutaAccept :: q -> Bool- }--{-| This function runs the transition function of a DUTA on the given-term. -}--runDUTATrans :: Functor f => DUTATrans f q -> Term f -> q-runDUTATrans = cata--{-| This function checks whether a given DUTA accepts a term. -}--duta :: Functor f => DUTA f q -> Term f -> Bool-duta DUTA{dutaTrans = trans, dutaAccept = accept} = accept . runDUTATrans trans----{-| This type represents transition functions of non-deterministic-bottom-up tree acceptors (NUTAs). -}--type NUTATrans f q = AlgM [] f q---{-| This type represents non-deterministic bottom-up tree acceptors.--}-data NUTA f q = NUTA {- nutaTrans :: AlgM [] f q,- nutaAccept :: q -> Bool- }--{-| This function runs the given transition function of a NUTA on the-given term -}--runNUTATrans :: Traversable f => NUTATrans f q -> Term f -> [q]-runNUTATrans = cataM--{-| This function checks whether a given NUTA accepts a term. -}--nuta :: Traversable f => NUTA f q -> Term f -> Bool-nuta NUTA{nutaTrans = trans, nutaAccept = accept} = any accept . runNUTATrans trans---{-| This function determinises the given NUTA. -}--determNUTA :: (Traversable f) => NUTA f q -> DUTA f [q]-determNUTA n = DUTA{- dutaTrans = algM $ nutaTrans n,- dutaAccept = any $ nutaAccept n}--{-| This function represents transition functions of-deterministic bottom-up tree transducers (DUTTs). -}--type DUTTTrans f g q = forall a. f (q,a) -> (q, Cxt Hole g a)--{-| This function transforms a DUTT transition function into an-algebra. -}--duttTransAlg :: (Functor f, Functor g) => DUTTTrans f g q -> Alg f (q, Term g)-duttTransAlg trans = fmap injectCxt . trans --{-| This function runs the given DUTT transition function on the given-term. -}--runDUTTTrans :: (Functor f, Functor g) => DUTTTrans f g q -> Term f -> (q, Term g)-runDUTTTrans = cata . duttTransAlg--{-| This data type represents deterministic bottom-up tree-transducers. -}--data DUTT f g q = DUTT {- duttTrans :: DUTTTrans f g q,- duttAccept :: q -> Bool- }--{-| This function transforms the given term according to the given-DUTT and returns the resulting term provided it is accepted by the-DUTT. -}--dutt :: (Functor f, Functor g) => DUTT f g q -> Term f -> Maybe (Term g)-dutt DUTT{duttTrans = trans, duttAccept = accept} = accept' . runDUTTTrans trans- where accept' (q,res)- | accept q = Just res- | otherwise = Nothing--{-| This type represents transition functions of non-deterministic-bottom-up tree transducers (NUTTs). -}--type NUTTTrans f g q = forall a. f (q,a) -> [(q, Cxt Hole g a)]--{-| This function transforms a NUTT transition function into a monadic-algebra. -}--nuttTransAlg :: (Functor f, Functor g) => NUTTTrans f g q -> AlgM [] f (q, Term g)-nuttTransAlg trans = liftM (fmap injectCxt) . trans --{-| This function runs the given NUTT transition function on the given-term. -}--runNUTTTrans :: (Traversable f, Functor g) => NUTTTrans f g q -> Term f -> [(q, Term g)]-runNUTTTrans = cataM . nuttTransAlg--{-| This data type represents non-deterministic bottom-up tree-transducers (NUTTs). -}--data NUTT f g q = NUTT {- nuttTrans :: NUTTTrans f g q,- nuttAccept :: q -> Bool- }--{-| This function transforms the given term according to the given-NUTT and returns a list containing all accepted results. -}--nutt :: (Traversable f, Functor g) => NUTT f g q -> Term f -> [Term g]-nutt NUTT{nuttTrans = trans, nuttAccept = accept} = mapMaybe accept' . runNUTTTrans trans- where accept' (q,res)- | accept q = Just res- | otherwise = Nothing
src/Data/Comp/DeepSeq.hs view
@@ -22,7 +22,6 @@ where import Data.Comp.Term-import Data.Comp.Sum import Control.DeepSeq import Data.Comp.Derive import Data.Foldable@@ -36,11 +35,7 @@ rnf (Hole x) = rnf x rnf (Term x) = rnfF x -instance (NFDataF f, NFDataF g) => NFDataF (f:+:g) where- rnfF (Inl v) = rnfF v- rnfF (Inr v) = rnfF v- instance NFData Nothing where --$(derive [instanceNFDataF] [''Maybe, ''[], ''(,)])+$(derive [liftSum] [''NFDataF])+$(derive [makeNFDataF] [''Maybe, ''[], ''(,)])
src/Data/Comp/Derive.hs view
@@ -16,9 +16,7 @@ module Data.Comp.Derive ( derive,- -- * First-order Signatures- -- |Derive boilerplate instances for first-order signatures, i.e.- -- signatures for ordinary compositional data types.+ -- |Derive boilerplate instances for compositional data type signatures. -- ** ShowF module Data.Comp.Derive.Show,@@ -28,7 +26,7 @@ module Data.Comp.Derive.Ordering, -- ** Functor Functor,- instanceFunctor,+ makeFunctor, -- ** Foldable module Data.Comp.Derive.Foldable, -- ** Traversable@@ -36,31 +34,19 @@ -- ** Arbitrary module Data.Comp.Derive.Arbitrary, NFData(..),- instanceNFData,+ makeNFData, -- ** DeepSeq module Data.Comp.Derive.DeepSeq, -- ** Smart Constructors module Data.Comp.Derive.SmartConstructors,-- -- * Higher-order Signatures- -- |Derive boilerplate instances for higher-order signatures, i.e.- -- signatures for generalised compositional data types.-- -- ** HShowF- module Data.Comp.Derive.Multi.Show,- -- ** HEqF- module Data.Comp.Derive.Multi.Equality,- -- ** HFunctor- module Data.Comp.Derive.Multi.Functor,- -- ** HFoldable- module Data.Comp.Derive.Multi.Foldable,- -- ** HTraversable- module Data.Comp.Derive.Multi.Traversable,- -- ** Smart Constructors- module Data.Comp.Derive.Multi.SmartConstructors+ -- ** Smart Constructors w/ Annotations+ module Data.Comp.Derive.SmartAConstructors,+ -- ** Lifting to Sums+ module Data.Comp.Derive.LiftSum ) where import Control.DeepSeq (NFData(..))+import Data.Comp.Derive.Utils (derive) import Data.Comp.Derive.Foldable import Data.Comp.Derive.Traversable import Data.Comp.Derive.DeepSeq@@ -69,34 +55,19 @@ import Data.Comp.Derive.Equality import Data.Comp.Derive.Arbitrary import Data.Comp.Derive.SmartConstructors-import Data.Comp.Derive.Multi.Equality-import Data.Comp.Derive.Multi.Show-import Data.Comp.Derive.Multi.Functor-import Data.Comp.Derive.Multi.Foldable-import Data.Comp.Derive.Multi.Traversable-import Data.Comp.Derive.Multi.SmartConstructors+import Data.Comp.Derive.SmartAConstructors+import Data.Comp.Derive.LiftSum import Language.Haskell.TH-import Control.Monad import qualified Data.DeriveTH as D-import Data.Derive.All--{-| Helper function for generating a list of instances for a list of named- signatures. For example, in order to derive instances 'Functor' and- 'ShowF' for a signature @Exp@, use derive as follows (requires Template- Haskell):-- > $(derive [instanceFunctor, instanceShowF] [''Exp])- -}-derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]-derive ders names = liftM concat $ sequence [der name | der <- ders, name <- names]+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. -}-instanceFunctor :: Name -> Q [Dec]-instanceFunctor = D.derive makeFunctor+makeFunctor :: Name -> Q [Dec]+makeFunctor = D.derive A.makeFunctor {-| Derive an instance of 'NFData' for a type constructor. -}-instanceNFData :: Name -> Q [Dec]-instanceNFData = D.derive makeNFData+makeNFData :: Name -> Q [Dec]+makeNFData = D.derive A.makeNFData
src/Data/Comp/Derive/Arbitrary.hs view
@@ -15,19 +15,19 @@ module Data.Comp.Derive.Arbitrary ( ArbitraryF(..),- instanceArbitraryF,+ makeArbitraryF, Arbitrary(..),- instanceArbitrary+ makeArbitrary )where import Test.QuickCheck-import Data.Comp.Derive.Utils+import Data.Comp.Derive.Utils hiding (derive) import Language.Haskell.TH-import Data.DeriveTH+import qualified Data.DeriveTH as D {-| Derive an instance of 'Arbitrary' for a type constructor. -}-instanceArbitrary :: Name -> Q [Dec]-instanceArbitrary = derive makeArbitrary+makeArbitrary :: Name -> Q [Dec]+makeArbitrary = D.derive D.makeArbitrary {-| Signature arbitration. An instance @ArbitraryF f@ gives rise to an instance @Arbitrary (Term f)@. -}@@ -43,8 +43,8 @@ first-order kind taking at least one argument. It is necessary that all types that are used by the data type definition are themselves instances of 'Arbitrary'. -}-instanceArbitraryF :: Name -> Q [Dec]-instanceArbitraryF dt = do+makeArbitraryF :: Name -> Q [Dec]+makeArbitraryF dt = do TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify dt let argNames = (map (VarT . tyVarBndrName) (tail args)) complType = foldl AppT (ConT name) argNames
src/Data/Comp/Derive/DeepSeq.hs view
@@ -15,7 +15,7 @@ module Data.Comp.Derive.DeepSeq ( NFDataF(..),- instanceNFDataF+ makeNFDataF ) where @@ -31,8 +31,8 @@ {-| Derive an instance of 'NFDataF' for a type constructor of any first-order kind taking at least one argument. -}-instanceNFDataF :: Name -> Q [Dec]-instanceNFDataF fname = do+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))
src/Data/Comp/Derive/Equality.hs view
@@ -14,7 +14,7 @@ module Data.Comp.Derive.Equality ( EqF(..),- instanceEqF+ makeEqF ) where import Data.Comp.Derive.Utils@@ -29,8 +29,8 @@ {-| Derive an instance of 'EqF' for a type constructor of any first-order kind taking at least one argument. -}-instanceEqF :: Name -> Q [Dec]-instanceEqF fname = do+makeEqF :: Name -> Q [Dec]+makeEqF fname = do TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname let argNames = (map (VarT . tyVarBndrName) (init args)) complType = foldl AppT (ConT name) argNames
src/Data/Comp/Derive/Foldable.hs view
@@ -15,7 +15,7 @@ module Data.Comp.Derive.Foldable ( Foldable,- instanceFoldable+ makeFoldable ) where import Data.Comp.Derive.Utils@@ -38,8 +38,8 @@ {-| Derive an instance of 'Foldable' for a type constructor of any first-order kind taking at least one argument. -}-instanceFoldable :: Name -> Q [Dec]-instanceFoldable fname = do+makeFoldable :: Name -> Q [Dec]+makeFoldable fname = do TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname let fArg = VarT . tyVarBndrName $ last args argNames = (map (VarT . tyVarBndrName) (init args))
+ src/Data/Comp/Derive/Injections.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Derive.Injections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature injections.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Injections+ (+ injn,+ injectn,+ deepInjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Term+import Data.Comp.Algebra (CxtFun, appSigFun)+import Data.Comp.Ops ((:+:)(..), (:<:)(..))++injn :: Int -> Q [Dec]+injn n = do+ let i = mkName $ "inj" ++ show n+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let xvar = mkName "x"+ let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar) : d+ where genSig fvars gvar avar = do+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = arrowT `appT` (tp `appT` varT avar)+ `appT` (varT gvar `appT` varT avar)+ forallT (map PlainTV $ gvar : avar : fvars)+ (sequence cxt) tp'+ genDecl x n = [| case $(varE x) of+ Inl x -> $(varE $ mkName $ "inj") x+ Inr x -> $(varE $ mkName $ "inj" +++ if n > 2 then show (n - 1) else "") x |]+injectn :: Int -> Q [Dec]+injectn n = do+ let i = mkName ("inject" ++ show n)+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let d = [funD i [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar) : d+ where genSig fvars gvar avar = do+ let hvar = mkName "h"+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar+ `appT` varT avar+ let tp'' = arrowT `appT` (tp `appT` tp') `appT` tp'+ forallT (map PlainTV $ hvar : gvar : avar : fvars)+ (sequence cxt) tp''+ genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]++deepInjectn :: Int -> Q [Dec]+deepInjectn n = do+ let i = mkName ("deepInject" ++ show n)+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let d = [funD i [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD i $ genSig fvars gvar) : d+ where genSig fvars gvar = do+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let cxt' = classP ''Functor [tp]+ let tp' = conT ''CxtFun `appT` tp `appT` varT gvar+ forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
+ src/Data/Comp/Derive/LiftSum.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Derive.LiftSum+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Lift a class declaration for difunctors to sums of functors.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.LiftSum+ (+ liftSum,+ caseF+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.Sum+import Data.Comp.Ops ((:+:)(..))++{-| 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+ as @instance (ShowF f, ShowF g) => ShowF (f :+: g) where ... @. -}+liftSum :: Name -> Q [Dec]+liftSum fname = do+ ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname+ let targs' = map tyVarBndrName $ tail targs+ let f = mkName "f"+ let g = mkName "g"+ let cxt = [ClassP name (map VarT $ f : targs'),+ ClassP name (map VarT $ g : targs')]+ let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)+ let complType = foldl (\a x -> a `AppT` VarT x) tp targs'+ decs' <- sequence $ concatMap decl decs+ return [InstanceD cxt complType decs']+ where decl :: Dec -> [DecQ]+ decl (SigD f _) = [funD f [clause f]]+ decl _ = []+ clause :: Name -> ClauseQ+ clause f = do x <- newName "x"+ b <- normalB [|caseF $(varE f) $(varE f) $(varE x)|]+ return $ Clause [VarP x] b []++{-| 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+caseF f g x = case x of+ Inl x -> f x+ Inr x -> g x
− src/Data/Comp/Derive/Multi/Equality.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Derive.Multi.Equality--- Copyright : (c) 2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ Automatically derive instances of @HEqF@.-------------------------------------------------------------------------------------module Data.Comp.Derive.Multi.Equality- (- HEqF(..),- KEq(..),- instanceHEqF- ) where--import Data.Comp.Derive.Utils-import Data.Comp.Multi.Functor-import Language.Haskell.TH hiding (Cxt, match)---class KEq f where- keq :: f i -> f j -> Bool--{-| Signature equality. An instance @HEqF f@ gives rise to an instance- @KEq (HTerm f)@. -}-class HEqF f where-- heqF :: KEq g => f g i -> f g j -> Bool---instance KEq f => Eq (f i) where- (==) = keq--instance Eq a => KEq (K a) where- keq (K x) (K y) = x == y--instance KEq a => Eq (A a) where- A x == A y = x `keq` y--{-| Derive an instance of 'HEqF' for a type constructor of any higher-order- kind taking at least two arguments. -}-instanceHEqF :: Name -> Q [Dec]-instanceHEqF fname = do- TyConI (DataD _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- classType = AppT (ConT ''HEqF) complType- constrs' <- mapM normalConExp constrs- eqFDecl <- funD 'heqF (eqFClauses ftyp constrs constrs')- return [InstanceD 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 - 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'- vars = map VarE varNs- vars' = map VarE varNs'- mkEq ty x y = let (x',y') = (return x,return y)- in if containsType ty ftyp- then [| $x' `keq` $y'|]- else [| $x' == $y'|]- eqs = listE $ zipWith3 mkEq argts vars vars'- body <- if n == 0 - then [|True|]- else [|and $eqs|]- return $ Clause [pat, pat'] (NormalB body) []
− src/Data/Comp/Derive/Multi/Foldable.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Derive.Multi.Foldable--- Copyright : (c) 2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ Automatically derive instances of @HFoldable@.--------------------------------------------------------------------------------------module Data.Comp.Derive.Multi.Foldable- (- HFoldable,- instanceHFoldable- )where--import Data.Comp.Derive.Utils-import Data.Comp.Multi.Functor-import Data.Comp.Multi.Foldable-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---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)--iterSp n f g e = run n e- where run 0 e = e- run m e = let f' = iter (m-1) [|fmap|] (if n == m then g else f)- in run (m-1) (f' `appE` e)--{-| Derive an instance of 'HFoldable' for a type constructor of any higher-order- kind taking at least two arguments. -}-instanceHFoldable :: Name -> Q [Dec]-instanceHFoldable fname = do- TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname- let args' = init args- fArg = VarT . tyVarBndrName $ last args'- argNames = (map (VarT . tyVarBndrName) (init args'))- complType = P.foldl AppT (ConT name) argNames- classType = AppT (ConT ''HFoldable) complType- constrs' <- mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs- foldDecl <- funD 'hfold (map foldClause constrs')- 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)- 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- mkPat [] _ = WildP- mkPat _ x = VarP x- mkPatAndVars (constr, args) =- do varNs <- newNames (length args) "x"- return (mkCPat constr args varNs, filterVars args varNs)- foldClause (pat,vars) =- do let conApp (0,x) = [|unK $x|]- conApp (d,x) = iterSp d [|fold|] [| foldMap unK |] x- body <- if null vars- then [|mempty|]- else P.foldl1 (\ x y -> [|$x `mappend` $y|])- $ map conApp vars- return $ Clause [pat] (NormalB body) []- foldMapClause (pat,vars) =- do fn <- newName "y"- let f = varE fn- f' 0 = f- f' n = iter (n-1) [|fmap|] [| foldMap $f |]- fp = if null vars then WildP else VarP fn- body <- case vars of- [] -> [|mempty|]- (_:_) -> 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) =- do fn <- newName "f"- en <- newName "e"- let f = varE fn- e = varE en- fp = if null vars then WildP else VarP fn- ep = VarP en- conApp x (0,y) = [|$f $x $y|]- conApp x (1,y) = [|foldl $f $x $y|]- conApp x (d,y) = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldl $f)|] `appE` y- endo = iter' (d-1) [|fold|] hidEndo- in [| appEndo $endo $x|]- body <- P.foldl conApp e vars- return $ Clause [fp, ep, pat] (NormalB body) []- foldrClause (pat,vars) =- do fn <- newName "f"- en <- newName "e"- let f = varE fn- e = varE en- fp = if null vars then WildP else VarP fn- ep = VarP en- conApp (0,x) y = [|$f $x $y|]- conApp (1,x) y = [|foldr $f $y $x |]- conApp (d,x) y = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldr $f)|] `appE` x- endo = iter' (d-1) [|fold|] hidEndo- in [| appEndo $endo $y|]- body <- P.foldr conApp e vars- return $ Clause [fp, ep, pat] (NormalB body) []
− src/Data/Comp/Derive/Multi/Functor.hs
@@ -1,63 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Derive.Multi.Functor--- Copyright : (c) 2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ Automatically derive instances of @HFunctor@.--------------------------------------------------------------------------------------module Data.Comp.Derive.Multi.Functor- (- HFunctor,- instanceHFunctor- ) where--import Data.Comp.Derive.Utils-import Data.Comp.Multi.Functor-import Language.Haskell.TH-import qualified Prelude as P (mapM)-import Prelude hiding (mapM)-import Data.Maybe-import Control.Monad--iter 0 _ e = e-iter n f e = iter (n-1) f (f `appE` e)--{-| Derive an instance of 'HFunctor' for a type constructor of any higher-order- kind taking at least two arguments. -}-instanceHFunctor :: Name -> Q [Dec]-instanceHFunctor fname = do- TyConI (DataD _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- 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)- 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- 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))- hfmapClause (con, pat,vars',hasFargs,_,_) =- do fn <- newName "f"- let f = varE fn- fp = if hasFargs then VarP fn else WildP- vars = vars' (\d x -> iter d [|fmap|] f `appE` x) id- body <- foldl appE con vars- return $ Clause [fp, pat] (NormalB body) []
− src/Data/Comp/Derive/Multi/Show.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE TemplateHaskell, TypeOperators #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Derive.Multi.Show--- Copyright : (c) 2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ Automatically derive instances of @HShowF@.--------------------------------------------------------------------------------------module Data.Comp.Derive.Multi.Show- (- HShowF(..),- KShow(..),- instanceHShowF- ) where--import Data.Comp.Derive.Utils-import Data.Comp.Multi.Functor-import Data.Comp.Multi.Algebra-import Language.Haskell.TH--{-| Signature printing. An instance @HShowF f@ gives rise to an instance- @KShow (HTerm f)@. -}-class HShowF f where- hshowF :: Alg f (K String)- hshowF = K . hshowF'- hshowF' :: f (K String) :=> String- hshowF' = unK . hshowF--class KShow a where- kshow :: a i -> K String i--showConstr :: String -> [String] -> String-showConstr con [] = con-showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"--{-| Derive an instance of 'HShowF' for a type constructor of any higher-order- kind taking at least two arguments. -}-instanceHShowF :: Name -> Q [Dec]-instanceHShowF fname = do- TyConI (DataD _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- classType = AppT (ConT ''HShowF) complType- constrs' <- mapM normalConExp constrs- showFDecl <- funD 'hshowF (showFClauses fArg constrs')- return [InstanceD 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 - let n = length args- varNs <- newNames n "x"- let pat = ConP constr $ map VarP varNs- allVars = zipWith (filterFarg fArg) args varNs- shows = listE $ map mkShow allVars- conName = nameBase constr- body <- [|K $ showConstr conName $shows|]- return $ Clause [pat] (NormalB body) []
− src/Data/Comp/Derive/Multi/SmartConstructors.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------- |--- Module : Data.Comp.Derive.Multi.SmartConstructors--- Copyright : (c) 2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ Automatically derive smart constructors for mutually recursive types.--------------------------------------------------------------------------------------module Data.Comp.Derive.Multi.SmartConstructors - (smartHConstructors) where--import Language.Haskell.TH hiding (Cxt)-import Data.Comp.Derive.Utils-import Data.Comp.Multi.Sum-import Data.Comp.Multi.Term--import Control.Monad--{-| 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. -}-smartHConstructors :: Name -> Q [Dec]-smartHConstructors 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 $val|]) []]]- sequence $ sig ++ function- genSig targs tname sname 0 = (:[]) $ do- fvar <- newName "f"- hvar <- newName "h"- avar <- newName "a"- ivar <- newName "i"- let targs' = init $ init targs- vars = fvar:hvar:avar:ivar:targs'- f = varT fvar- h = varT hvar- a = varT avar- i = varT ivar- ftype = foldl appT (conT tname) (map varT targs')- constr = classP ''(:<:) [ftype, f]- typ = foldl appT (conT ''Cxt) [h, f, a, i]- typeSig = forallT (map PlainTV vars) (sequence [constr]) typ- sigD sname typeSig- genSig _ _ _ _ = []
− src/Data/Comp/Derive/Multi/Traversable.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Derive.Multi.Traversable--- Copyright : (c) 2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ Automatically derive instances of @HTraversable@.--------------------------------------------------------------------------------------module Data.Comp.Derive.Multi.Traversable- (- HTraversable,- instanceHTraversable- ) where--import Data.Comp.Derive.Utils-import Data.Comp.Multi.Traversable-import Language.Haskell.TH-import Data.Maybe-import Data.Traversable-import Data.Foldable hiding (any,or)-import Control.Applicative-import Control.Monad hiding (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. -}-instanceHTraversable :: Name -> Q [Dec]-instanceHTraversable fname = do- TyConI (DataD _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- classType = AppT (ConT ''HTraversable) complType- 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)- 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- 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,_,_) =- 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) []- -- 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 = P.foldl appE con allVars- 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) []
src/Data/Comp/Derive/Ordering.hs view
@@ -14,7 +14,7 @@ module Data.Comp.Derive.Ordering ( OrdF(..),- instanceOrdF+ makeOrdF ) where import Data.Comp.Derive.Equality@@ -35,8 +35,8 @@ {-| Derive an instance of 'OrdF' for a type constructor of any first-order kind taking at least one argument. -}-instanceOrdF :: Name -> Q [Dec]-instanceOrdF fname = do+makeOrdF :: Name -> Q [Dec]+makeOrdF fname = do TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname let argNames = (map (VarT . tyVarBndrName) (init args)) complType = foldl AppT (ConT name) argNames
+ src/Data/Comp/Derive/Projections.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TemplateHaskell, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Derive.Projections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature projections.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.Projections+ (+ projn,+ projectn,+ deepProjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Control.Monad (liftM)+import Data.Traversable (Traversable)+import Data.Comp.Term+import Data.Comp.Algebra (CxtFunM, appSigFunM')+import Data.Comp.Ops ((:+:)(..), (:<:)(..))++projn :: Int -> Q [Dec]+projn n = do+ let p = mkName $ "proj" ++ show n+ let gvars = map (\n -> mkName $ 'g' : show n) [1..n]+ let avar = mkName "a"+ let xvar = mkName "x"+ let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar) []]]+ sequence $ (sigD p $ genSig gvars avar) : d+ where genSig gvars avar = do+ let fvar = mkName "f"+ let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars+ let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)+ (map varT gvars)+ let tp' = arrowT `appT` (varT fvar `appT` varT avar)+ `appT` (conT ''Maybe `appT`+ (tp `appT` varT avar))+ forallT (map PlainTV $ fvar : avar : gvars) (sequence cxt) tp'+ genDecl x [g] a =+ [| liftM inj (proj $(varE x)+ :: Maybe ($(varT g `appT` varT a))) |]+ genDecl x (g:gs) a =+ [| case (proj $(varE x)+ :: Maybe ($(varT g `appT` varT a))) of+ Just y -> Just $ inj y+ _ -> $(genDecl x gs a) |]+ genDecl _ _ _ = error "genDecl called with empty list"++projectn :: Int -> Q [Dec]+projectn n = do+ let p = mkName ("project" ++ show n)+ let gvars = map (\n -> mkName $ 'g' : show n) [1..n]+ let avar = mkName "a"+ let xvar = mkName "x"+ let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]+ sequence $ (sigD p $ genSig gvars avar) : d+ where genSig gvars avar = do+ let fvar = mkName "f"+ let hvar = mkName "h"+ let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars+ let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)+ (map varT gvars)+ let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar+ `appT` varT avar+ let tp'' = arrowT `appT` tp'+ `appT` (conT ''Maybe `appT` (tp `appT` tp'))+ forallT (map PlainTV $ hvar : fvar : avar : gvars)+ (sequence cxt) tp''+ genDecl x n = [| case $(varE x) of+ Hole _ -> Nothing+ Term t -> $(varE $ mkName $ "proj" ++ show n) t |]++deepProjectn :: Int -> Q [Dec]+deepProjectn n = do+ let p = mkName ("deepProject" ++ show n)+ let gvars = map (\n -> mkName $ 'g' : show n) [1..n]+ let d = [funD p [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD p $ genSig gvars) : d+ where genSig gvars = do+ let fvar = mkName "f"+ let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars+ let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)+ (map varT gvars)+ let cxt' = classP ''Traversable [tp]+ let tp' = conT ''CxtFunM `appT` conT ''Maybe+ `appT` varT fvar `appT` tp+ forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
src/Data/Comp/Derive/Show.hs view
@@ -15,7 +15,7 @@ module Data.Comp.Derive.Show ( ShowF(..),- instanceShowF+ makeShowF ) where import Data.Comp.Derive.Utils@@ -32,8 +32,8 @@ {-| Derive an instance of 'ShowF' for a type constructor of any first-order kind taking at least one argument. -}-instanceShowF :: Name -> Q [Dec]-instanceShowF fname = do+makeShowF :: Name -> Q [Dec]+makeShowF fname = do TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname let fArg = VarT . tyVarBndrName $ last args argNames = (map (VarT . tyVarBndrName) (init args))
+ src/Data/Comp/Derive/SmartAConstructors.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Derive.SmartAConstructors+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive smart constructors with annotations.+--+--------------------------------------------------------------------------------++module Data.Comp.Derive.SmartAConstructors+ (+ smartAConstructors+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.Sum+import Data.Comp.Term+import Data.Comp.Annotation+import Control.Monad++{-| Derive smart constructors with products for a type constructor of any+ parametric kind taking at least one argument. The smart constructors are+ similar to the ordinary constructors, but an 'injectA' 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|] $ foldl appE (conE name) vars+ function = [funD sname [clause pats (normalB [|Term $val|]) []]]+ sequence function
src/Data/Comp/Derive/SmartConstructors.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE TemplateHaskell #-}- -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Derive.Signature@@ -14,15 +13,14 @@ -------------------------------------------------------------------------------- module Data.Comp.Derive.SmartConstructors - (smartConstructors) where--+ (+ smartConstructors+ ) where import Language.Haskell.TH hiding (Cxt) import Data.Comp.Derive.Utils import Data.Comp.Sum import Data.Comp.Term- import Control.Monad {-| Derive smart constructors for a type constructor of any first-order kind
src/Data/Comp/Derive/Traversable.hs view
@@ -15,7 +15,7 @@ module Data.Comp.Derive.Traversable ( Traversable,- instanceTraversable+ makeTraversable ) where import Data.Comp.Derive.Utils@@ -38,8 +38,8 @@ {-| Derive an instance of 'Traversable' for a type constructor of any first-order kind taking at least one argument. -}-instanceTraversable :: Name -> Q [Dec]-instanceTraversable fname = do+makeTraversable :: Name -> Q [Dec]+makeTraversable fname = do TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname let fArg = VarT . tyVarBndrName $ last args argNames = (map (VarT . tyVarBndrName) (init args))
src/Data/Comp/Derive/Utils.hs view
@@ -99,3 +99,12 @@ tupleTypes n m = map tupleTypeName [n..m] +{-| Helper function for generating a list of instances for a list of named+ signatures. For example, in order to derive instances 'Functor' and+ 'ShowF' for a signature @Exp@, use derive as follows (requires Template+ Haskell):++ > $(derive [makeFunctor, makeShowF] [''Exp])+ -}+derive :: [Name -> Q [Dec]] -> [Name] -> Q [Dec]+derive ders names = liftM concat $ sequence [der name | der <- ders, name <- names]
+ src/Data/Comp/Desugar.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,+ UndecidableInstances, OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Desugar+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This modules defines the 'Desugar' type class for desugaring of terms.+--+--------------------------------------------------------------------------------++module Data.Comp.Desugar where++import Data.Comp+import Data.Comp.Derive++-- |The desugaring term homomorphism.+class (Functor f, Functor g) => Desugar f g where+ desugHom :: TermHom f g+ desugHom = desugHom' . fmap Hole+ desugHom' :: Alg f (Context g a)+ desugHom' x = appCxt (desugHom x)++$(derive [liftSum] [''Desugar])++-- |Desugar a term.+desugar :: Desugar f g => Term f -> Term g+{-# INLINE desugar #-}+desugar = appTermHom desugHom++-- |Lift desugaring to annotated terms.+desugarA :: (Functor f', Functor g', DistAnn f p f', DistAnn g p g',+ Desugar f g) => Term f' -> Term g'+desugarA = appTermHom (propAnn desugHom)++-- |Default desugaring instance.+instance (Functor f, Functor g, f :<: g) => Desugar f g where+ desugHom = simpCxt . inj
src/Data/Comp/Equality.hs view
@@ -20,6 +20,7 @@ import Data.Comp.Term import Data.Comp.Sum+import Data.Comp.Ops import Data.Comp.Derive import Data.Comp.Derive.Utils @@ -72,4 +73,4 @@ unit' = fmap (const ()) args = toList s `zip` toList t -$(derive [instanceEqF] $ (''Maybe) : tupleTypes 2 10)+$(derive [makeEqF] $ (''Maybe) : tupleTypes 2 10)
src/Data/Comp/Multi.hs view
@@ -3,55 +3,48 @@ -- Module : Data.Comp.Multi -- Copyright : (c) 2011 Patrick Bahr -- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>+-- Maintainer : Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk> -- Stability : experimental -- Portability : non-portable (GHC Extensions) ----- This module defines the infrastructure necessary to use compositional data--- types for mutually recursive data types. Examples of usage are provided--- below.+-- This module defines the infrastructure necessary to use+-- /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@. -- -------------------------------------------------------------------------------- module Data.Comp.Multi (- -- * Examples- -- ** Pure Computations- -- $ex1-- -- ** Monadic Computations- -- $ex2-- -- ** Composing Term Homomorphisms and Algebras- -- $ex3-- -- ** Lifting Term Homomorphisms to Products- -- $ex4 module Data.Comp.Multi.Term- , module Data.Comp.Multi.Algebra , module Data.Comp.Multi.Functor+ , module Data.Comp.Multi.Algebra , module Data.Comp.Multi.Sum- , module Data.Comp.Multi.Product+ , module Data.Comp.Multi.Annotation+ , module Data.Comp.Multi.Equality+ , module Data.Comp.Multi.Generic ) where +import Data.Comp.Multi.Functor import Data.Comp.Multi.Term import Data.Comp.Multi.Algebra-import Data.Comp.Multi.Functor import Data.Comp.Multi.Sum-import Data.Comp.Multi.Product+import Data.Comp.Multi.Annotation+import Data.Comp.Multi.Equality+import Data.Comp.Multi.Generic {- $ex1-The example below illustrates how to use generalised compositional data types +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: @TemplateHaskell@, @TypeOperators@,-@MultiParamTypeClasses@, @FlexibleInstances@, @FlexibleContexts@,-@UndecidableInstances@, and @GADTs@. Moreover, in order to derive instances for-GADTs, version 7 of GHC is needed.+The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,+@GADTs@. Besides, GCH 7 is required. > import Data.Comp.Multi > import Data.Comp.Multi.Show ()-> import Data.Comp.Derive+> import Data.Comp.Multi.Derive > > -- Signature for values and operators > data Value e l where@@ -61,17 +54,17 @@ > 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 [instanceHFunctor, instanceHShowF, smartHConstructors] +> $(derive [makeHFunctor, makeHShowF, makeHEqF, smartConstructors] > [''Value, ''Op]) > > -- Term evaluation algebra > class Eval f v where-> evalAlg :: Alg f (HTerm v)+> evalAlg :: Alg f (Term v) > > instance (Eval f v, Eval g v) => Eval (f :+: g) v where > evalAlg (Inl x) = evalAlg x@@ -102,19 +95,18 @@ -} {- $ex2-The example below illustrates how to use generalised compositional data types to+The example illustrates how to use generalised compositional data types to 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: @TemplateHaskell@,-@TypeOperators@, @MultiParamTypeClasses@, @FlexibleInstances@,-@FlexibleContexts@, @UndecidableInstances@, and @GADTs@. Moreover, in order to-derive instances for GADTs, version 7 of GHC is needed.+The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,+@GADTs@. Besides, GCH 7 is required. > import Data.Comp.Multi > import Data.Comp.Multi.Show ()-> import Data.Comp.Derive+> import Data.Comp.Multi.Derive > import Control.Monad (liftM) > > -- Signature for values and operators@@ -130,8 +122,8 @@ > type Sig = Op :+: Value > > -- Derive boilerplate code using Template Haskell (GHC 7 needed)-> $(derive [instanceHFunctor, instanceHTraversable, instanceHFoldable,-> instanceHEqF, instanceHShowF, smartHConstructors]+> $(derive [makeHFunctor, makeHTraversable, makeHFoldable,+> makeHEqF, makeHShowF, smartConstructors] > [''Value, ''Op]) > > -- Monadic term evaluation algebra@@ -142,8 +134,7 @@ > evalAlgM (Inl x) = evalAlgM x > evalAlgM (Inr x) = evalAlgM x > -> evalM :: (HTraversable f, EvalM f v) => Term f l-> -> Maybe (Term v l)+> evalM :: (HTraversable f, EvalM f v) => Term f l -> Maybe (Term v l) > evalM = cataM evalAlgM > > instance (Value :<: v) => EvalM Value v where@@ -174,17 +165,74 @@ -} {- $ex3-The example below illustrates how to compose a term homomorphism and an algebra,+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.++The following language extensions are needed in order to run the example:+@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,+@GADTs@. Besides, GCH 7 is required.++> 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+> Pair :: e s -> e t -> Value e (s,t)+> data Op e l where+> 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] +> [''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)+-}++{- $ex4+The example illustrates how to compose a term homomorphism and an algebra, exemplified via a desugaring term homomorphism and an evaluation algebra. The following language extensions are needed in order to run the example: @TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,-@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@. -Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,+@GADTs@. Besides, GCH 7 is required. > import Data.Comp.Multi > import Data.Comp.Multi.Show ()-> import Data.Comp.Derive+> import Data.Comp.Multi.Derive > > -- Signature for values, operators, and syntactic sugar > data Value e l where@@ -197,7 +245,7 @@ > 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@@ -205,14 +253,14 @@ > -- 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 [instanceHFunctor, instanceHTraversable, instanceHFoldable,-> instanceHEqF, instanceHShowF, smartHConstructors]+> $(derive [makeHFunctor, makeHTraversable, makeHFoldable,+> makeHEqF, makeHShowF, smartConstructors] > [''Value, ''Op, ''Sugar]) > > -- Term homomorphism for desugaring of terms@@ -237,7 +285,7 @@ > 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)@@ -254,13 +302,13 @@ > 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) => HTerm v (s,t) -> (HTerm v s, HTerm v t)+> +> 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@@ -271,19 +319,19 @@ > evalEx = eval $ iSwap $ iPair (iConst 1) (iConst 2) -} -{- $ex4-The example below illustrates how to lift a term homomorphism to products,+{- $ex5+The example illustrates how to lift a term homomorphism to annotations, exemplified via a desugaring term homomorphism lifted to terms annotated with source position information. The following language extensions are needed in order to run the example: @TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,-@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@.- Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.+@FlexibleInstances@, @FlexibleContexts@, and @UndecidableInstances@,+@GADTs@. Besides, GCH 7 is required. > import Data.Comp.Multi > import Data.Comp.Multi.Show ()-> import Data.Comp.Derive+> import Data.Comp.Multi.Derive > > -- Signature for values, operators, and syntactic sugar > data Value e l where@@ -296,22 +344,22 @@ > 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+> 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 [instanceHFunctor, instanceHTraversable, instanceHFoldable,-> instanceHEqF, instanceHShowF, smartHConstructors]+> $(derive [makeHFunctor, makeHTraversable, makeHFoldable,+> makeHEqF, makeHShowF, smartConstructors] > [''Value, ''Op, ''Sugar]) > > -- Term homomorphism for desugaring of terms@@ -336,34 +384,34 @@ > 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 = appTermHom 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 = appTermHom (productTermHom desugHom)->-> iSwapP :: (DistProd f p f', Sugar :<: f) => p -> Term f' (a,b) -> Term f' (b,a)-> iSwapP p x = Term (injectP p $ inj $ Swap x)->-> iConstP :: (DistProd f p f', Value :<: f) => p -> Int -> Term f' Int-> iConstP p x = Term (injectP p $ inj $ Const x)->-> iPairP :: (DistProd f p f', Value :<: f) => p -> Term f' a -> Term f' b -> Term f' (a,b)-> iPairP p x y = Term (injectP p $ inj $ Pair x y)->-> iFstP :: (DistProd f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' a-> iFstP p x = Term (injectP p $ inj $ Fst x)->-> iSndP :: (DistProd f p f', Op :<: f) => p -> Term f' (a,b) -> Term f' b-> iSndP p x = Term (injectP p $ inj $ Snd x)->+> desugP = appTermHom (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)@@ -374,80 +422,4 @@ > desugPEx :: Term SigP (Int,Int) > desugPEx = desugP $ iSwapP (Pos 1 0) (iPairP (Pos 1 1) (iConstP (Pos 1 2) 1) > (iConstP (Pos 1 3) 2))--}--{- $ex5-The example below illustrates how to use Higher-Order Abstract Syntax (HOAS)-with generalised compositional data types.--The following language extensions are needed in order to run the example:-@TemplateHaskell@, @TypeOperators@, @MultiParamTypeClasses@,-@FlexibleInstances@, @FlexibleContexts@, @UndecidableInstances@, and @GADTs@.-Moreover, in order to derive instances for GADTs, version 7 of GHC is needed.--> import Data.Comp.Multi-> import Data.Comp.Derive-> -> data Value e l where-> Const :: Int -> Value e Int-> Pair :: e s -> e t -> Value e (s,t)-> data Op e l where-> Add, Mult :: e Int -> e Int -> Op e Int-> Fst :: e (s,t) -> Op e s-> Snd :: e (s,t) -> Op e t-> data Lam e l where-> Lam :: (e l1 -> e l2) -> Lam e (l1 -> l2)-> data App e l where-> App :: e (l1 -> l2) -> e l1 -> App e l2->-> -- Signature for values-> type Val = Lam :++: Value->-> -- Signature for expressions-> type Sig = App :++: Op :++: Val-> -> -- Derive boilerplate code using Template Haskell (GHC 7 needed)-> $(derive [instanceHExpFunctor, smartHConstructors] -> [''Value, ''Op, ''Lam, ''App])-> -> -- Term evaluation algebra-> class Eval f v where-> evalAlg :: HAlg f (HTerm v)-> -> instance (Eval f v, Eval g v) => Eval (f :++: g) v where-> evalAlg (HInl x) = evalAlg x-> evalAlg (HInr x) = evalAlg x-> -> -- Lift the evaluation algebra to a catamorphism-> evalE :: (HExpFunctor f, Eval f v) => HTerm f :-> HTerm v-> evalE = hcataE evalAlg-> -> instance (Value :<<: v) => Eval Value v where-> evalAlg = hinject-> -> 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->-> instance (Lam :<<: v) => Eval Lam v where-> evalAlg = hinject->-> instance (Lam :<<: v) => Eval App v where-> evalAlg (App x y) = (projL x) y->-> projC :: (Value :<<: v) => HTerm v Int -> Int-> projC v = case hproject v of Just (Const n) -> n-> -> projP :: (Value :<<: v) => HTerm v (s,t) -> (HTerm v s, HTerm v t)-> projP v = case hproject v of Just (Pair x y) -> (x,y)->-> projL :: (Lam :<<: v) => HTerm v (l1 -> l2) -> HTerm v l1 -> HTerm v l2-> projL v = case hproject v of Just (Lam f) -> f-> -> -- Example: evalEEx = iConst 3-> evalEEx :: HTerm Val Int-> evalEEx = evalE (((iLam $ \x -> x) `iApp`-> (iConst 1 `iAdd` iConst 2)) :: HTerm Sig Int) -}
src/Data/Comp/Multi/Algebra.hs view
@@ -25,7 +25,6 @@ -- * Monadic Algebras & Catamorphisms AlgM,--- halgM, freeM, cataM, cataM',@@ -36,27 +35,25 @@ SigFun, TermHom, appTermHom,+ appTermHom', compTermHom, appSigFun,+ appSigFun', compSigFun, termHom, compAlg,--- compCoalg,--- compCVCoalg, -- * Monadic Term Homomorphisms CxtFunM, SigFunM, TermHomM,--- SigFunM',--- TermHomM', sigFunM,--- termHom',+ termHom', appTermHomM,+ appTermHomM', termHomM,--- termHomM', appSigFunM,--- appSigFunM',+ appSigFunM', compTermHomM, compSigFunM, compAlgM,@@ -65,7 +62,6 @@ -- * Coalgebras & Anamorphisms Coalg, ana,--- ana', CoalgM, anaM, @@ -81,18 +77,10 @@ RCoalgM, apoM, - -- * CV-Algebras & Histomorphisms- -- $l1--- CVAlg,--- histo,--- CVAlgM,--- histoM, -- * CV-Coalgebras & Futumorphisms CVCoalg, futu,--- CVCoalg',--- futu', CVCoalgM, futuM, ) where@@ -104,9 +92,12 @@ import Data.Comp.Ops import Control.Monad -+-- | This type represents multisorted @f@-algebras with a family @e@+-- of carriers. type Alg f e = f e :-> e +-- | Construct a catamorphism for contexts over @f@ with holes of type+-- @b@, from the given algebra. free :: forall f h a b . (HFunctor f) => Alg f b -> (a :-> b) -> Cxt h f a :-> b free f g = run@@ -114,17 +105,18 @@ run (Hole v) = g v run (Term c) = f $ hfmap run c -+-- | Construct a catamorphism from the given algebra. cata :: forall f a. HFunctor f => Alg f a -> Term f :-> a cata f = run where run :: Term f :-> a run (Term t) = f (hfmap run t) +-- | A generalisation of 'cata' from terms over @f@ to contexts over+-- @f@, where the holes have the type of the algebra carrier. cata' :: HFunctor f => Alg f e -> Cxt h f e :-> e cata' alg = free alg id -- | This function applies a whole context into another context.- appCxt :: HFunctor f => Context f (Cxt h f a) :-> Cxt h f a appCxt = cata' Term @@ -137,9 +129,12 @@ return $ I x turn x = do I y <- x return y-+-- | This type represents a monadic algebra. It is similar to 'Alg'+-- but the return type is monadic. type AlgM m f e = NatM m (f e) e +-- | Construct a monadic catamorphism for contexts over @f@ with holes+-- of type @b@, from the given monadic algebra. freeM :: forall f m h a b. (HTraversable f, Monad m) => AlgM m f b -> NatM m a b -> NatM m (Cxt h f a) b freeM algm var = run@@ -148,47 +143,52 @@ run (Term x) = hmapM run x >>= algm -- | This is a monadic version of 'cata'.- cataM :: forall f m a. (HTraversable f, Monad m) => AlgM m f a -> NatM m (Term f) a--- cataM alg h (Term t) = alg =<< hmapM (cataM alg h) t cataM alg = run where run :: NatM m (Term f) a run (Term x) = alg =<< hmapM run x+-- cataM alg h (Term t) = alg =<< hmapM (cataM alg h) t cataM' :: forall m h a f. (Monad m, HTraversable f) => AlgM m f a -> NatM m (Cxt h f a) a--- cataM' alg = freeM alg return cataM' f = run where run :: NatM m (Cxt h f a) a run (Hole x) = return x run (Term x) = hmapM run x >>= f+-- cataM' alg = freeM alg return --- | This type represents context function. -type CxtFun f g = forall a h. Cxt h f a :-> Cxt h g a- -- | This type represents uniform signature function specification.- type SigFun f g = forall a. f a :-> g a ---- | This type represents a term algebra.+-- | This type represents context function.+type CxtFun f g = forall h . SigFun (Cxt h f) (Cxt h g) +-- | This type represents term homomorphisms. type TermHom f g = SigFun f (Context g) -- | This function applies the given term homomorphism to a -- term/context.--appTermHom :: (HFunctor f, HFunctor g) => TermHom f g -> CxtFun f g+appTermHom :: forall f g . (HFunctor f, HFunctor g) => TermHom f g -> CxtFun f g -- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b)) -> Cxt h f b -> Cxt h g b -- would achieve the same. The given type is chosen for clarity.-appTermHom _ (Hole b) = Hole b-appTermHom f (Term t) = appCxt . f . hfmap (appTermHom f) $ t+appTermHom f = run where+ run :: CxtFun f g+ run (Hole b) = Hole b+ run (Term t) = appCxt . f . hfmap run $ t --- | This function composes two term algebras. +-- | This function applies the given term homomorphism to a+-- term/context. This is the top-down variant of 'appTermHom'.+appTermHom' :: forall f g . (HFunctor g) => TermHom f g -> CxtFun f g+appTermHom' f = run where+ run :: CxtFun f g+ run (Hole b) = Hole b+ run (Term t) = appCxt . hfmap run . f $ t++-- | This function composes two term algebras. compTermHom :: (HFunctor g, HFunctor h) => TermHom g h -> TermHom f g -> TermHom f h -- Note: The rank 2 type polymorphism is not necessary. Alternatively, also the type -- (Functor f, Functor g) => (f (Cxt h g b) -> Context g (Cxt h g b))@@ -197,52 +197,53 @@ compTermHom f g = appTermHom f . g -- | This function composes a term algebra with an algebra.- compAlg :: (HFunctor g) => Alg g a -> TermHom f g -> Alg f a compAlg alg talg = cata' alg . talg --- | This function applies a signature function to the given context.+-- | This function applies a signature function to the given+-- context. This is the top-down variant of 'appSigFun'.+appSigFun' :: forall f g. (HFunctor g) => SigFun f g -> CxtFun f g+appSigFun' f = run+ where run :: CxtFun f g+ run (Hole b) = Hole b+ run (Term t) = Term . hfmap run . f $ t -appSigFun :: (HFunctor f, HFunctor g) => SigFun f g -> CxtFun f g-appSigFun f = appTermHom $ termHom f+-- | This function applies a signature function to the given context.+appSigFun :: forall f g. (HFunctor f) => SigFun f g -> CxtFun f g+appSigFun f = run+ where run :: CxtFun f g+ run (Hole b) = Hole b+ run (Term t) = Term . f . hfmap run $ t -- | 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. termHom :: (HFunctor g) => SigFun f g -> TermHom f g termHom f = simpCxt . f --- | This type represents monadic context function.--type CxtFunM m f g = forall a h. NatM m (Cxt h f a) (Cxt h g a)- -- | This type represents monadic signature functions.- type SigFunM m f g = forall a. NatM m (f a) (g a) --- | This type represents monadic term algebras.+-- | This type represents monadic context function.+type CxtFunM m f g = forall h. SigFunM m (Cxt h f) (Cxt h g) ++-- | This type represents monadic term algebras. type TermHomM m f g = SigFunM m f (Context g) -- | This function lifts the given signature function to a monadic -- signature function. Note that term algebras are instances of -- signature functions. Hence this function also applies to term -- algebras.- sigFunM :: (Monad m) => SigFun f g -> SigFunM m f g sigFunM f = return . f -- | This function lifts the give monadic signature function to a -- monadic term algebra.- termHom' :: (HFunctor f, HFunctor g, Monad m) => SigFunM m f g -> TermHomM m f g termHom' f = liftM (Term . hfmap Hole) . f@@ -259,17 +260,39 @@ appTermHomM :: forall f g m . (HTraversable f, HFunctor g, Monad m) => TermHomM m f g -> CxtFunM m f g appTermHomM f = run- where run :: NatM m (Cxt h f a) (Cxt h g a)+ where run :: CxtFunM m f g run (Hole b) = return $ Hole b run (Term t) = liftM appCxt . (>>= f) . hmapM run $ t +-- | This function applies the given monadic term homomorphism to the+-- given term/context. This is a top-down variant of 'appTermHomM'.++appTermHomM' :: forall f g m . (HTraversable g, Monad m)+ => TermHomM m f g -> CxtFunM m f g+appTermHomM' f = run+ where run :: CxtFunM m f g+ run (Hole b) = return $ Hole b+ run (Term t) = liftM appCxt . hmapM run =<< f t+ -- | This function applies the given monadic signature function to the -- given context. -appSigFunM :: (HTraversable f, HFunctor g, Monad m) =>+appSigFunM :: forall f g m. (HTraversable f, Monad m) => SigFunM m f g -> CxtFunM m f g-appSigFunM f = appTermHomM $ termHom' f+appSigFunM f = run+ where run :: CxtFunM m f g+ run (Hole b) = return $ Hole b+ run (Term t) = liftM Term . f =<< hmapM run t +-- | This function applies the given monadic signature function to the+-- given context. This is a top-down variant of 'appSigFunM'.+appSigFunM' :: forall f g m. (HTraversable g, Monad m) =>+ SigFunM m f g -> CxtFunM m f g+appSigFunM' f = run+ where run :: CxtFunM m f g+ run (Hole b) = return $ Hole b+ run (Term t) = liftM Term . hmapM run =<< f t+ -- | This function composes two monadic term algebras. compTermHomM :: (HTraversable g, HFunctor h, Monad m)@@ -388,15 +411,6 @@ run' :: NatM m (Term f :+: a) (Term f) run' (Inl t) = return t run' (Inr a) = run a--------------------------------------- CV-Algebras & Histomorphisms ----------------------------------------- $l1 For this to work we need a more general version of @:&&:@ which is of--- kind @((* -> *) -> * -> *) -> (* -> *) -> (* -> *) -> * -> *@,--- i.e. one which takes a functor as second argument instead of a--- type. ----------------------------------- -- CV-Coalgebras & Futumorphisms --
+ src/Data/Comp/Multi/Annotation.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses,+ FlexibleInstances, UndecidableInstances, RankNTypes, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Annotation+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines annotations on signatures. All definitions are+-- generalised versions of those in "Data.Comp.Annotation".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Annotation+ (+ (:&:) (..),+ DistAnn (..),+ RemA (..),+ liftA,+ ann,+ liftA',+ stripA,+ propAnn,+ 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.Functor++import Control.Monad++-- | This function transforms 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 :-> t) -> s a :-> t+liftA f v = f (remA v)+++-- | This function annotates each sub term of the given term with the+-- given value (of type a).++ann :: (DistAnn f p g, HFunctor f) => p -> CxtFun f g+ann c = appSigFun (injectA c)++-- | This function transforms 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, HFunctor s')+ => (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. -}++stripA :: (RemA g f, HFunctor g) => CxtFun g f+stripA = appSigFun remA+++propAnn :: (DistAnn f p f', DistAnn g p g', HFunctor g) + => TermHom f g -> TermHom 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' :: (RemA s s',s :<: f) =>+-- NatM Maybe (Cxt h f a) (s' (Cxt h f a))+project' v = liftM remA $ project v
+ src/Data/Comp/Multi/Derive.hs view
@@ -0,0 +1,48 @@+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive+-- Copyright : (c) 2010-2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module contains functionality for automatically deriving boilerplate+-- code using Template Haskell. Examples include instances of 'HFunctor',+-- 'HFoldable', and 'HTraversable'.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive+ (+ derive,+ -- |Derive boilerplate instances for higher-order signatures, i.e.+ -- signatures for generalised compositional data types.++ -- ** HShowF+ module Data.Comp.Multi.Derive.Show,+ -- ** HEqF+ module Data.Comp.Multi.Derive.Equality,+ -- ** HFunctor+ module Data.Comp.Multi.Derive.Functor,+ -- ** HFoldable+ module Data.Comp.Multi.Derive.Foldable,+ -- ** HTraversable+ module Data.Comp.Multi.Derive.Traversable,+ -- ** Smart Constructors+ module Data.Comp.Multi.Derive.SmartConstructors,+ -- ** Smart Constructors w/ Annotations+ module Data.Comp.Multi.Derive.SmartAConstructors,+ -- ** Lifting to Sums+ module Data.Comp.Multi.Derive.LiftSum+ ) where++import Data.Comp.Derive.Utils (derive)+import Data.Comp.Multi.Derive.Equality+import Data.Comp.Multi.Derive.Show+import Data.Comp.Multi.Derive.Functor+import Data.Comp.Multi.Derive.Foldable+import Data.Comp.Multi.Derive.Traversable+import Data.Comp.Multi.Derive.SmartConstructors+import Data.Comp.Multi.Derive.SmartAConstructors+import Data.Comp.Multi.Derive.LiftSum
+ src/Data/Comp/Multi/Derive/Equality.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.Equality+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @HEqF@.+--+--------------------------------------------------------------------------------+module Data.Comp.Multi.Derive.Equality+ (+ HEqF(..),+ KEq(..),+ makeHEqF+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Language.Haskell.TH hiding (Cxt, match)+++class KEq f where+ keq :: f i -> f j -> Bool++{-| Signature equality. An instance @HEqF f@ gives rise to an instance+ @KEq (HTerm f)@. -}+class HEqF f where++ heqF :: KEq g => f g i -> f g j -> Bool+++instance KEq f => Eq (f i) where+ (==) = keq++instance Eq a => KEq (K a) where+ keq (K x) (K y) = x == y++instance KEq a => Eq (A a) where+ A x == A y = x `keq` y++{-| Derive an instance of 'HEqF' for a type constructor of any higher-order+ kind taking at least two arguments. -}+makeHEqF :: Name -> Q [Dec]+makeHEqF fname = do+ TyConI (DataD _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+ classType = AppT (ConT ''HEqF) complType+ constrs' <- mapM normalConExp constrs+ eqFDecl <- funD 'heqF (eqFClauses ftyp constrs constrs')+ return [InstanceD 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 + 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'+ vars = map VarE varNs+ vars' = map VarE varNs'+ mkEq ty x y = let (x',y') = (return x,return y)+ in if containsType ty ftyp+ then [| $x' `keq` $y'|]+ else [| $x' == $y'|]+ eqs = listE $ zipWith3 mkEq argts vars vars'+ body <- if n == 0 + then [|True|]+ else [|and $eqs|]+ return $ Clause [pat, pat'] (NormalB body) []
+ src/Data/Comp/Multi/Derive/Foldable.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.Foldable+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @HFoldable@.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.Foldable+ (+ HFoldable,+ makeHFoldable+ )where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable+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+++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)++iterSp n f g e = run n e+ where run 0 e = e+ run m e = let f' = iter (m-1) [|fmap|] (if n == m then g else f)+ in run (m-1) (f' `appE` e)++{-| Derive an instance of 'HFoldable' for a type constructor of any higher-order+ kind taking at least two arguments. -}+makeHFoldable :: Name -> Q [Dec]+makeHFoldable fname = do+ TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+ let args' = init args+ fArg = VarT . tyVarBndrName $ last args'+ argNames = (map (VarT . tyVarBndrName) (init args'))+ complType = P.foldl AppT (ConT name) argNames+ classType = AppT (ConT ''HFoldable) complType+ constrs' <- mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs+ foldDecl <- funD 'hfold (map foldClause constrs')+ 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)+ 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+ mkPat [] _ = WildP+ mkPat _ x = VarP x+ mkPatAndVars (constr, args) =+ do varNs <- newNames (length args) "x"+ return (mkCPat constr args varNs, filterVars args varNs)+ foldClause (pat,vars) =+ do let conApp (0,x) = [|unK $x|]+ conApp (d,x) = iterSp d [|fold|] [| foldMap unK |] x+ body <- if null vars+ then [|mempty|]+ else P.foldl1 (\ x y -> [|$x `mappend` $y|])+ $ map conApp vars+ return $ Clause [pat] (NormalB body) []+ foldMapClause (pat,vars) =+ do fn <- newName "y"+ let f = varE fn+ f' 0 = f+ f' n = iter (n-1) [|fmap|] [| foldMap $f |]+ fp = if null vars then WildP else VarP fn+ body <- case vars of+ [] -> [|mempty|]+ (_:_) -> 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) =+ do fn <- newName "f"+ en <- newName "e"+ let f = varE fn+ e = varE en+ fp = if null vars then WildP else VarP fn+ ep = VarP en+ conApp x (0,y) = [|$f $x $y|]+ conApp x (1,y) = [|foldl $f $x $y|]+ conApp x (d,y) = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldl $f)|] `appE` y+ endo = iter' (d-1) [|fold|] hidEndo+ in [| appEndo $endo $x|]+ body <- P.foldl conApp e vars+ return $ Clause [fp, ep, pat] (NormalB body) []+ foldrClause (pat,vars) =+ do fn <- newName "f"+ en <- newName "e"+ let f = varE fn+ e = varE en+ fp = if null vars then WildP else VarP fn+ ep = VarP en+ conApp (0,x) y = [|$f $x $y|]+ conApp (1,x) y = [|foldr $f $y $x |]+ conApp (d,x) y = let hidEndo = iter (d-1) [|fmap|] [|Endo . flip (foldr $f)|] `appE` x+ endo = iter' (d-1) [|fold|] hidEndo+ in [| appEndo $endo $y|]+ body <- P.foldr conApp e vars+ return $ Clause [fp, ep, pat] (NormalB body) []
+ src/Data/Comp/Multi/Derive/Functor.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.Functor+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @HFunctor@.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.Functor+ (+ HFunctor,+ makeHFunctor+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Language.Haskell.TH+import qualified Prelude as P (mapM)+import Prelude hiding (mapM)+import Data.Maybe+import Control.Monad++iter 0 _ e = e+iter n f e = iter (n-1) f (f `appE` e)++{-| Derive an instance of 'HFunctor' for a type constructor of any higher-order+ kind taking at least two arguments. -}+makeHFunctor :: Name -> Q [Dec]+makeHFunctor fname = do+ TyConI (DataD _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+ 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)+ 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+ 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))+ hfmapClause (con, pat,vars',hasFargs,_,_) =+ do fn <- newName "f"+ let f = varE fn+ fp = if hasFargs then VarP fn else WildP+ vars = vars' (\d x -> iter d [|fmap|] f `appE` x) id+ body <- foldl appE con vars+ return $ Clause [fp, pat] (NormalB body) []
+ src/Data/Comp/Multi/Derive/Injections.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.Injections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature injections.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.Injections+ (+ injn,+ injectn,+ deepInjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Term+import Data.Comp.Multi.Algebra (CxtFun, appSigFun)+import Data.Comp.Multi.Ops ((:+:)(..), (:<:)(..))++injn :: Int -> Q [Dec]+injn n = do+ let i = mkName $ "inj" ++ show n+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let ivar = mkName "i"+ let xvar = mkName "x"+ let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar ivar) : d+ where genSig fvars gvar avar ivar = do+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = arrowT `appT` (tp `appT` varT avar `appT` varT ivar)+ `appT` (varT gvar `appT` varT avar+ `appT` varT ivar)+ forallT (map PlainTV $ gvar : avar : ivar : fvars)+ (sequence cxt) tp'+ genDecl x n = [| case $(varE x) of+ Inl x -> $(varE $ mkName $ "inj") x+ Inr x -> $(varE $ mkName $ "inj" +++ if n > 2 then show (n - 1) else "") x |]+injectn :: Int -> Q [Dec]+injectn n = do+ let i = mkName ("inject" ++ show n)+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let ivar = mkName "i"+ let d = [funD i [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar ivar) : d+ where genSig fvars gvar avar ivar = do+ let hvar = mkName "h"+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar+ `appT` varT avar+ let tp'' = arrowT `appT` (tp `appT` tp' `appT` varT ivar)+ `appT` (tp' `appT` varT ivar)+ forallT (map PlainTV $ hvar : gvar : avar : ivar : fvars)+ (sequence cxt) tp''+ genDecl n = [| Term . $(varE $ mkName $ "inj" ++ show n) |]++deepInjectn :: Int -> Q [Dec]+deepInjectn n = do+ let i = mkName ("deepInject" ++ show n)+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let d = [funD i [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD i $ genSig fvars gvar) : d+ where genSig fvars gvar = do+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let cxt' = classP ''HFunctor [tp]+ let tp' = conT ''CxtFun `appT` tp `appT` varT gvar+ forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
+ src/Data/Comp/Multi/Derive/LiftSum.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.LiftSum+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Lift a class declaration for higher-order functors to sums of higher-order+-- functors.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.LiftSum+ (+ liftSum,+ caseH+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Ops ((:+:)(..))++{-| Given the name of a type class, where the first parameter is a higher-order+ functor, lift it to sums of higher-order. Example: @class HShowF f where ...@+ is lifted as @instance (HShowF f, HShowF g) => HShowF (f :+: g) where ... @.+ -}+liftSum :: Name -> Q [Dec]+liftSum fname = do+ ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname+ let targs' = map tyVarBndrName $ tail targs+ let f = mkName "f"+ let g = mkName "g"+ let cxt = [ClassP name (map VarT $ f : targs'),+ ClassP name (map VarT $ g : targs')]+ let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)+ let complType = foldl (\a x -> a `AppT` VarT x) tp targs'+ decs' <- sequence $ concatMap decl decs+ return [InstanceD cxt complType decs']+ where decl :: Dec -> [DecQ]+ decl (SigD f _) = [funD f [clause f]]+ decl _ = []+ clause :: Name -> ClauseQ+ clause f = do x <- newName "x"+ b <- normalB [|caseH $(varE f) $(varE f) $(varE x)|]+ return $ Clause [VarP x] b []++{-| Utility function to case on a higher-order functor sum, without exposing the+ internal representation of sums. -}+caseH :: (f a b -> c) -> (g a b -> c) -> (f :+: g) a b -> c+caseH f g x = case x of+ Inl x -> f x+ Inr x -> g x
+ src/Data/Comp/Multi/Derive/Projections.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE TemplateHaskell, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.Projections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature projections.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.Projections+ (+ projn,+ projectn,+ deepProjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Control.Monad (liftM)+import Data.Comp.Multi.Traversable (HTraversable)+import Data.Comp.Multi.Term+import Data.Comp.Multi.Algebra (CxtFunM, appSigFunM')+import Data.Comp.Multi.Ops ((:+:)(..), (:<:)(..))++projn :: Int -> Q [Dec]+projn n = do+ let p = mkName $ "proj" ++ show n+ let gvars = map (\n -> mkName $ 'g' : show n) [1..n]+ let avar = mkName "a"+ let ivar = mkName "i"+ let xvar = mkName "x"+ let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar gvars avar ivar) []]]+ sequence $ (sigD p $ genSig gvars avar ivar) : d+ where genSig gvars avar ivar = do+ let fvar = mkName "f"+ let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars+ let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)+ (map varT gvars)+ let tp' = arrowT+ `appT` (varT fvar `appT` varT avar `appT` varT ivar)+ `appT` (conT ''Maybe `appT`+ (tp `appT` varT avar `appT` varT ivar))+ forallT (map PlainTV $ fvar : ivar : avar : gvars)+ (sequence cxt) tp'+ genDecl x [g] a i =+ [| liftM inj (proj $(varE x)+ :: Maybe ($(varT g `appT` varT a `appT` varT i))) |]+ genDecl x (g:gs) a i =+ [| case (proj $(varE x)+ :: Maybe ($(varT g `appT` varT a `appT` varT i))) of+ Just y -> Just $ inj y+ _ -> $(genDecl x gs a i) |]+ genDecl _ _ _ _ = error "genDecl called with empty list"++projectn :: Int -> Q [Dec]+projectn n = do+ let p = mkName ("project" ++ show n)+ let gvars = map (\n -> mkName $ 'g' : show n) [1..n]+ let avar = mkName "a"+ let ivar = mkName "i"+ let xvar = mkName "x"+ let d = [funD p [clause [varP xvar] (normalB $ genDecl xvar n) []]]+ sequence $ (sigD p $ genSig gvars avar ivar) : d+ where genSig gvars avar ivar = do+ let fvar = mkName "f"+ let hvar = mkName "h"+ let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars+ let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)+ (map varT gvars)+ let tp' = conT ''Cxt `appT` varT hvar `appT` varT fvar+ `appT` varT avar+ let tp'' = arrowT `appT` (tp' `appT` varT ivar)+ `appT` (conT ''Maybe `appT`+ (tp `appT` tp' `appT` varT ivar))+ forallT (map PlainTV $ hvar : fvar : avar : ivar : gvars)+ (sequence cxt) tp''+ genDecl x n = [| case $(varE x) of+ Hole _ -> Nothing+ Term t -> $(varE $ mkName $ "proj" ++ show n) t |]++deepProjectn :: Int -> Q [Dec]+deepProjectn n = do+ let p = mkName ("deepProject" ++ show n)+ let gvars = map (\n -> mkName $ 'g' : show n) [1..n]+ let d = [funD p [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD p $ genSig gvars) : d+ where genSig gvars = do+ let fvar = mkName "f"+ let cxt = map (\g -> classP ''(:<:) [varT g, varT fvar]) gvars+ let tp = foldl1 (\a g -> conT ''(:+:) `appT` g `appT` a)+ (map varT gvars)+ let cxt' = classP ''HTraversable [tp]+ let tp' = conT ''CxtFunM `appT` conT ''Maybe+ `appT` varT fvar `appT` tp+ forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
+ src/Data/Comp/Multi/Derive/Show.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.Show+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @HShowF@.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.Show+ (+ HShowF(..),+ KShow(..),+ makeHShowF+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Algebra+import Language.Haskell.TH++{-| Signature printing. An instance @HShowF f@ gives rise to an instance+ @KShow (HTerm f)@. -}+class HShowF f where+ hshowF :: Alg f (K String)+ hshowF = K . hshowF'+ hshowF' :: f (K String) :=> String+ hshowF' = unK . hshowF++class KShow a where+ kshow :: a i -> K String i++showConstr :: String -> [String] -> String+showConstr con [] = con+showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"++{-| Derive an instance of 'HShowF' for a type constructor of any higher-order+ kind taking at least two arguments. -}+makeHShowF :: Name -> Q [Dec]+makeHShowF fname = do+ TyConI (DataD _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+ classType = AppT (ConT ''HShowF) complType+ constrs' <- mapM normalConExp constrs+ showFDecl <- funD 'hshowF (showFClauses fArg constrs')+ return [InstanceD 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 + let n = length args+ varNs <- newNames n "x"+ let pat = ConP constr $ map VarP varNs+ allVars = zipWith (filterFarg fArg) args varNs+ shows = listE $ map mkShow allVars+ conName = nameBase constr+ body <- [|K $ showConstr conName $shows|]+ return $ Clause [pat] (NormalB body) []
+ src/Data/Comp/Multi/Derive/SmartAConstructors.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.SmartAConstructors+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive smart constructors with annotations.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.SmartAConstructors + (+ smartAConstructors+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Term+import Data.Comp.Multi.Annotation+import Control.Monad++{-| Derive smart constructors with products for a type constructor of any+ parametric kind taking at least two arguments. The smart constructors are+ similar to the ordinary constructors, but an 'injectA' 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|] $ foldl appE (conE name) vars+ function = [funD sname [clause pats (normalB [|Term $val|]) []]]+ sequence function
+ src/Data/Comp/Multi/Derive/SmartConstructors.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.SmartConstructors+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive smart constructors for mutually recursive types.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.SmartConstructors + (+ smartConstructors+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Term++import Control.Monad++{-| 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+ let iVar = tyVarBndrName $ last targs+ let cons = map (\con -> (abstractConType con, iTp iVar con)) 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 $val|]) []]]+ sequence $ sig ++ function+ genSig targs tname sname 0 miTp = (:[]) $ do+ fvar <- newName "f"+ hvar <- newName "h"+ avar <- newName "a"+ ivar <- newName "i"+ let targs' = init $ init targs+ vars = hvar:fvar:avar:(maybe [ivar] (const []) miTp)++targs'+ f = varT fvar+ h = varT hvar+ a = varT avar+ i = varT ivar+ ftype = foldl appT (conT tname) (map varT targs')+ constr = classP ''(:<:) [ftype, f]+ typ = foldl appT (conT ''Cxt) [h, f, a, maybe i return miTp]+ typeSig = forallT (map PlainTV vars) (sequence [constr]) typ+ sigD sname typeSig+ genSig _ _ _ _ _ = []
+ src/Data/Comp/Multi/Derive/Traversable.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Derive.Traversable+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @HTraversable@.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Derive.Traversable+ (+ HTraversable,+ makeHTraversable+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Multi.Traversable+import Language.Haskell.TH+import Data.Maybe+import Data.Traversable+import Data.Foldable hiding (any,or)+import Control.Applicative+import Control.Monad hiding (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+ let args' = init args+ fArg = VarT . tyVarBndrName $ last args'+ argNames = (map (VarT . tyVarBndrName) (init args'))+ complType = foldl AppT (ConT name) argNames+ classType = AppT (ConT ''HTraversable) complType+ 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)+ 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+ 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,_,_) =+ 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) []+ -- 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 = P.foldl appE con allVars+ 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) []
+ src/Data/Comp/Multi/Desugar.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,+ UndecidableInstances, TypeOperators, OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Desugar+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This modules defines the 'Desugar' type class for desugaring of terms.+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Desugar where++import Data.Comp.Multi+import Data.Comp.Multi.Derive++-- |The desugaring term homomorphism.+class (HFunctor f, HFunctor g) => Desugar f g where+ desugHom :: TermHom f g+ desugHom = desugHom' . hfmap Hole+ desugHom' :: Alg f (Context g a)+ desugHom' x = appCxt (desugHom x)++$(derive [liftSum] [''Desugar])++-- |Desugar a term.+desugar :: Desugar f g => Term f :-> Term g+desugar = appTermHom desugHom++-- |Lift desugaring to annotated terms.+desugarA :: (HFunctor f', HFunctor g', DistAnn f p f', DistAnn g p g',+ Desugar f g) => Term f' :-> Term g'+desugarA = appTermHom (propAnn desugHom)++-- |Default desugaring instance.+instance (HFunctor f, HFunctor g, f :<: g) => Desugar f g where+ desugHom = simpCxt . inj
src/Data/Comp/Multi/Equality.hs view
@@ -22,7 +22,8 @@ import Data.Comp.Multi.Term import Data.Comp.Multi.Sum-import Data.Comp.Derive+import Data.Comp.Multi.Ops+import Data.Comp.Multi.Derive import Data.Comp.Multi.Functor import Data.Comp.Multi.Foldable
+ src/Data/Comp/Multi/Generic.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE GADTs, ExistentialQuantification, TypeOperators, ScopedTypeVariables, RankNTypes #-}++--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Multi.Generic+-- Copyright : (c) 2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines type generic functions and recursive schemes+-- along the lines of the Uniplate library. All definitions are+-- generalised versions of those in "Data.Comp.Generic".+--+--------------------------------------------------------------------------------++module Data.Comp.Multi.Generic where++import Data.Comp.Multi.Term+import Data.Comp.Multi.Sum+import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable+import Data.Comp.Multi.Traversable+import GHC.Exts+import Control.Monad+import Prelude++import Data.Maybe++-- | This function returns a list of all subterms of the given+-- term. This function is similar to Uniplate's @universe@ function.+subterms :: forall f . HFoldable f => Term f :=> [A (Term f)]+subterms t = build (f t)+ where f :: Term f :=> (A (Term f) -> b -> b) -> b -> b+ f t cons nil = A 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 :=> [A (g (Term f))]+subterms' (Term t) = build (f t)+ where f :: f (Term f) :=> (A (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' -> A t' `cons` rest+ Nothing -> rest++-- | This function transforms every subterm according to the given+-- function in a bottom-up manner. This function is similar to+-- Uniplate's @transform@ function.+transform :: forall f . (HFunctor f) => (Term f :-> Term f) -> Term f :-> Term f+transform f = run+ where run :: Term f :-> Term f+ run = f . Term . hfmap run . unTerm+++-- | 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 + 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 +-- 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++subs :: HFoldable f => Term f :=> [A (Term f)]+subs = query (\x-> [A x]) (++)++subs' :: (HFoldable f, g :<: f) => Term f :=> [A (g (Term f))]+subs' = mapMaybe pr . subs+ where pr (A v) = fmap A (project v)++-- | This function computes the generic size of the given term,+-- i.e. the its number of subterm occurrences.+size :: HFoldable f => Cxt h f a :=> Int+size (Hole {}) = 0+size (Term t) = hfoldl (\s x -> s + size x) 1 t++-- | This function computes the generic depth of the given term.+depth :: HFoldable f => Cxt h f a :=> Int+depth (Hole {}) = 0+depth (Term t) = 1 + hfoldl (\s x -> s + size x) 0 t
src/Data/Comp/Multi/Ops.hs view
@@ -120,40 +120,38 @@ htraverse f (v :&: c) = (:&: c) <$> (htraverse f v) hmapM f (v :&: c) = liftM (:&: c) (hmapM f v) --- | This class defines how to distribute a product over a sum of+-- | This class defines how to distribute an annotation over a sum of -- signatures.--class DistProd (s :: (* -> *) -> * -> *) p s' | s' -> s, s' -> p where- - -- | This function injects a product a value over a signature.- injectP :: p -> s a :-> s' a- projectP :: s' a :-> (s a O.:&: p)+class DistAnn (s :: (* -> *) -> * -> *) 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 RemoveP (s :: (* -> *) -> * -> *) s' | s -> s' where- removeP :: s a :-> s' a+class RemA (s :: (* -> *) -> * -> *) s' | s -> s' where+ remA :: s a :-> s' a -instance (RemoveP s s') => RemoveP (f :&: p :+: s) (f :+: s') where- removeP (Inl (v :&: _)) = Inl v- removeP (Inr v) = Inr $ removeP v+instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where+ remA (Inl (v :&: _)) = Inl v+ remA (Inr v) = Inr $ remA v -instance RemoveP (f :&: p) f where- removeP (v :&: _) = v+instance RemA (f :&: p) f where+ remA (v :&: _) = v -instance DistProd f p (f :&: p) where+instance DistAnn f p (f :&: p) where - injectP p v = v :&: p+ injectA p v = v :&: p - projectP (v :&: p) = v O.:&: p+ projectA (v :&: p) = v O.:&: p -instance (DistProd s p s') => DistProd (f :+: s) p ((f :&: p) :+: s') where- injectP p (Inl v) = Inl (v :&: p)- injectP p (Inr v) = Inr $ injectP p v+instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where+ injectA p (Inl v) = Inl (v :&: p)+ injectA p (Inr v) = Inr $ injectA p v - projectP (Inl (v :&: p)) = (Inl v O.:&: p)- projectP (Inr v) = let (v' O.:&: p) = projectP v+ projectA (Inl (v :&: p)) = (Inl v O.:&: p)+ projectA (Inr v) = let (v' O.:&: p) = projectA v in (Inr v' O.:&: p)
− src/Data/Comp/Multi/Product.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses,- FlexibleInstances, UndecidableInstances, RankNTypes, GADTs #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Multi.Product--- Copyright : (c) 2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ This module defines products on signatures. All definitions are--- generalised versions of those in "Data.Comp.Product".--------------------------------------------------------------------------------------module Data.Comp.Multi.Product- ( (:&:) (..),- DistProd (..),- RemoveP (..),- liftP,- constP,- liftP',- stripP,- productTermHom,- 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.Functor--import Control.Monad------- | This function transforms a function with a domain constructed--- from a functor to a function with a domain constructed with the--- same functor but with an additional product.--liftP :: (RemoveP s s') => (s' a :-> t) -> s a :-> t-liftP f v = f (removeP v)----- | This function annotates each sub term of the given term with the--- given value (of type a).--constP :: (DistProd f p g, HFunctor f, HFunctor g) - => p -> Cxt h f a :-> Cxt h g a-constP c = appSigFun (injectP c)---- | This function transforms a function with a domain constructed--- from a functor to a function with a domain constructed with the--- same functor but with an additional product.--liftP' :: (DistProd s' p s, HFunctor s, HFunctor s')- => (s' a :-> Cxt h s' a) -> s a :-> Cxt h s a-liftP' f v = let (v' O.:&: p) = projectP v- in constP p (f v')- -{-| This function strips the products from a term over a-functor whith products. -}--stripP :: (HFunctor f, RemoveP g f, HFunctor g)- => Cxt h g a :-> Cxt h f a-stripP = appSigFun removeP---productTermHom :: (DistProd f p f', DistProd g p g', HFunctor g, HFunctor g') - => TermHom f g -> TermHom f' g'-productTermHom alg f' = constP p (alg f)- where (f O.:&: p) = projectP f'-------- | This function is similar to 'project' but applies to signatures--- with a product which is then ignored.---- project' :: (RemoveP s s',s :<: f) =>--- NatM Maybe (Cxt h f a) (s' (Cxt h f a))-project' v = liftM removeP $ project v
src/Data/Comp/Multi/Show.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TypeOperators, GADTs, FlexibleContexts,- ScopedTypeVariables, UndecidableInstances, FlexibleInstances #-}+ ScopedTypeVariables, UndecidableInstances, FlexibleInstances,+ TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Multi.Show@@ -20,11 +21,10 @@ ) where import Data.Comp.Multi.Term-import Data.Comp.Multi.Sum-import Data.Comp.Multi.Product+import Data.Comp.Multi.Annotation import Data.Comp.Multi.Algebra import Data.Comp.Multi.Functor-import Data.Comp.Derive+import Data.Comp.Multi.Derive instance KShow Nothing where kshow _ = undefined@@ -44,6 +44,4 @@ instance (HShowF f, Show p) => HShowF (f :&: p) where hshowF (v :&: p) = K $ unK (hshowF v) ++ " :&: " ++ show p -instance (HShowF f, HShowF g) => HShowF (f :+: g) where- hshowF (Inl f) = hshowF f- hshowF (Inr g) = hshowF g+$(derive [liftSum] [''HShowF])
src/Data/Comp/Multi/Sum.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TypeOperators, GADTs, ScopedTypeVariables, IncoherentInstances,- RankNTypes #-}+ RankNTypes, FlexibleContexts, TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Multi.Sum@@ -16,31 +16,72 @@ module Data.Comp.Multi.Sum (- (:<:)(..),- (:+:)(..),+ (:<:),+ (:+:), -- * 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,--- 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, -- * Injections and Projections for Constants injectConst,@@ -58,95 +99,64 @@ 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) -{-| A variant of 'proj' for binary sum signatures. -}-proj2 :: forall f g1 g2 a i. (g1 :<: f, g2 :<: f) =>- f a i -> Maybe (((g1 :+: g2) a) i)-proj2 x = case proj x of- Just (y :: g1 a i) -> Just $ inj y- _ -> liftM inj (proj x :: Maybe (g2 a i))--{-| A variant of 'proj' for ternary sum signatures. -}-proj3 :: forall f g1 g2 g3 a i. (g1 :<: f, g2 :<: f, g3 :<: f) =>- f a i -> Maybe (((g1 :+: g2 :+: g3) a) i)-proj3 x = case proj x of- Just (y :: g1 a i) -> Just $ inj y- _ -> case proj x of- Just (y :: g2 a i) -> Just $ inj y- _ -> liftM inj (proj x :: Maybe (g3 a i))+$(liftM concat $ mapM projn [2..10]) --- |Project the outermost layer of a term to a sub signature.-project :: (g :<: f) => NatM Maybe (Cxt h f a) (g (Cxt h f a))+-- |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) (g (Cxt h f a)) project (Hole _) = Nothing project (Term t) = proj t --- |Project the outermost layer of a term to a binary sub signature.-project2 :: (g1 :<: f, g2 :<: f) =>- NatM Maybe (Cxt h f a) ((g1 :+: g2) (Cxt h f a))-project2 (Hole _) = Nothing-project2 (Term t) = proj2 t---- |Project the outermost layer of a term to a ternary sub signature.-project3 :: (g1 :<: f, g2 :<: f, g3 :<: f) =>- NatM Maybe (Cxt h f a) ((g1 :+: g2 :+: g3) (Cxt h f a))-project3 (Hole _) = Nothing-project3 (Term t) = proj3 t---- |Project a term to a term over a sub signature.-deepProject :: (HTraversable f, HFunctor g, g :<: f)- => NatM Maybe (Cxt h f a) (Cxt h g a)-deepProject = appSigFunM proj---- |Project a term to a term over a binary sub signature.-deepProject2 :: (HTraversable f, HFunctor g1, HFunctor g2,- g1 :<: f, g2 :<: f)- => NatM Maybe (Cxt h f a) (Cxt h (g1 :+: g2) a)-deepProject2 = appSigFunM proj2+$(liftM concat $ mapM projectn [2..10]) --- |Project a term to a term over a ternary sub signature.-deepProject3 :: (HTraversable f, HFunctor g1, HFunctor g2, HFunctor g3,- g1 :<: f, g2 :<: f, g3 :<: f)- => NatM Maybe (Cxt h f a) (Cxt h (g1 :+: g2 :+: g3) a)-deepProject3 = appSigFunM proj3+-- | 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 :: (HTraversable g, g :<: f) => CxtFunM Maybe f g+{-# INLINE deepProject #-}+deepProject = appSigFunM' proj -{-| A variant of 'inj' for binary sum signatures. -}-inj2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a :-> g a-inj2 (Inl x) = inj x-inj2 (Inr y) = inj y+$(liftM concat $ mapM deepProjectn [2..10])+{-# INLINE deepProject2 #-}+{-# INLINE deepProject3 #-}+{-# INLINE deepProject4 #-}+{-# INLINE deepProject5 #-}+{-# INLINE deepProject6 #-}+{-# INLINE deepProject7 #-}+{-# INLINE deepProject8 #-}+{-# INLINE deepProject9 #-}+{-# INLINE deepProject10 #-} -{-| A variant of 'inj' for ternary sum signatures. -}-inj3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a :-> g a-inj3 (Inl x) = inj x-inj3 (Inr y) = inj2 y+$(liftM concat $ mapM injn [2..10]) --- |Inject a term where the outermost layer is a sub signature.+-- |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 a term where the outermost layer is a binary sub signature.-inject2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) (Cxt h g a) :-> Cxt h g a-inject2 = Term . inj2---- |Inject a term where the outermost layer is a ternary sub signature.-inject3 :: (f1 :<: g, f2 :<: g, f3 :<: g)- => (f1 :+: f2 :+: f3) (Cxt h g a) :-> Cxt h g a-inject3 = Term . inj3+$(liftM concat $ mapM injectn [2..10]) --- |Inject a term over a sub signature to a term over larger signature.-deepInject :: (HFunctor g, HFunctor f, g :<: f) => Cxt h g a :-> Cxt h f a+-- |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 :: (HFunctor g, g :<: f) => CxtFun g f+{-# INLINE deepInject #-} deepInject = appSigFun inj --- |Inject a term over a binary sub signature to a term over larger signature.-deepInject2 :: (HFunctor f1, HFunctor f2, HFunctor g, f1 :<: g, f2 :<: g)- => Cxt h (f1 :+: f2) a :-> Cxt h g a-deepInject2 = appSigFun inj2---- |Inject a term over a ternary sub signature to a term over larger signature.-deepInject3 :: (HFunctor f1, HFunctor f2, HFunctor f3, HFunctor g,- f1 :<: g, f2 :<: g, f3 :<: g)- => Cxt h (f1 :+: f2 :+: f3) a :-> Cxt h g a-deepInject3 = appSigFun inj3+$(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 :: (HFunctor g, g :<: f) => Cxt h' g (Cxt h f a) :-> Cxt h f a
src/Data/Comp/Multi/Term.hs view
@@ -30,6 +30,13 @@ ) where import Data.Comp.Multi.Functor+import Data.Comp.Multi.Foldable+import Data.Comp.Multi.Traversable+import Data.Monoid++import Control.Monad+import Control.Applicative hiding (Const)+ import Unsafe.Coerce type Const (f :: (* -> *) -> * -> *) = f (K ())@@ -78,6 +85,40 @@ hfmap f (Hole x) = Hole (f x) hfmap f (Term t) = Term (hfmap (hfmap f) t) +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' op c a = run a c where+ run :: (Cxt h f) a :=> b -> b+ run (Hole a) e = a `op` e+ run (Term t) e = hfoldr run e t++ hfoldl = hfoldl' where+ hfoldl' :: forall a b. (b -> a :=> b) -> b -> Cxt h f a :=> b+ hfoldl' op = run where+ run :: b -> (Cxt h f) a :=> b+ run e (Hole a) = e `op` a+ run e (Term t) = hfoldl run e t++ hfold (Hole (K a)) = a+ hfold (Term t) = hfoldMap hfold t++ hfoldMap = hfoldMap' where+ hfoldMap' :: forall m a. Monoid m => (a :=> m) -> Cxt h f a :=> m+ hfoldMap' f = run where+ run :: Cxt h f a :=> m+ run (Hole a) = f a+ run (Term t) = hfoldMap run t++instance (HTraversable f) => HTraversable (Cxt h f) where+ hmapM = hmapM' where+ hmapM' :: forall m a b. (Monad m) => NatM m a b -> NatM m (Cxt h f a) (Cxt h f b)+ hmapM' f = run where+ run :: NatM m (Cxt h f a) (Cxt h f b)+ run (Hole x) = liftM Hole $ f x+ run (Term t) = liftM Term $ hmapM run t+ htraverse f (Hole x) = Hole <$> f x+ htraverse f (Term t) = Term <$> htraverse (htraverse f) t simpCxt :: (HFunctor f) => f a i -> Context f a i simpCxt = Term . hfmap Hole
src/Data/Comp/Multi/Variables.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,- OverlappingInstances, TypeOperators, KindSignatures, FlexibleContexts, ScopedTypeVariables, RankNTypes #-}-+ OverlappingInstances, TypeOperators, KindSignatures, FlexibleContexts, ScopedTypeVariables, RankNTypes, TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Multi.Variables@@ -11,8 +10,9 @@ -- Portability : non-portable (GHC Extensions) -- -- This module defines an abstract notion of (bound) variables in compositional--- data types, and capture-avoiding substitution. All definitions are--- generalised versions of those in "Data.Comp.Variables".+-- data types, and scoped substitution. Capture-avoidance is /not/ taken into+-- account. All definitions are generalised versions of those in+-- "Data.Comp.Variables". -- -------------------------------------------------------------------------------- module Data.Comp.Multi.Variables@@ -32,8 +32,8 @@ ) where import Data.Comp.Multi.Term-import Data.Comp.Multi.Sum import Data.Comp.Multi.Algebra+import Data.Comp.Multi.Derive import Data.Comp.Multi.Functor import Data.Comp.Multi.Foldable import Data.Set (Set)@@ -60,11 +60,7 @@ bindsVars :: f a :=> [v] bindsVars _ = [] -instance (HasVars f v, HasVars g v) => HasVars (f :+: g) v where- isVar (Inl v) = isVar v- isVar (Inr v) = isVar v- bindsVars (Inl v) = bindsVars v- bindsVars (Inr v) = bindsVars v+$(derive [liftSum] [''HasVars]) instance HasVars f v => HasVars (Cxt h f) v where isVar (Term t) = isVar t@@ -84,13 +80,13 @@ let vars' = vars ++ bindsVars t in case isVar t of Just v ->- -- Check for capture-avoidance+ -- Check for scope if v `elem` vars' then- Term $ hfmap (\x -> unC x vars') t+ Term $ hfmap (`unC` vars') t else Hole $ K v Nothing ->- Term $ hfmap (\x -> unC x vars') t+ Term $ hfmap (`unC` vars') t containsVarAlg :: (Eq v, HasVars f v, HFoldable f) => v -> Alg f (K Bool) containsVarAlg v t = K $ v `notElem` bindsVars t &&
+ src/Data/Comp/MultiParam.hs view
@@ -0,0 +1,34 @@+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the infrastructure necessary to use+-- /Generalised Parametric Compositional Data Types/. Generalised Parametric+-- Compositional Data Types is an extension of Compositional Data Types with+-- parametric higher-order abstract syntax (PHOAS) for usage with binders, and+-- GADTs. Generalised Parametric Compositional Data Types combines Generalised+-- Compositional Data Types ("Data.Comp.Multi") and Parametric Compositional+-- Data Types ("Data.Comp.Param"). Examples of usage are bundled with the+-- package in the library @examples\/Examples\/MultiParam@.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam (+ module Data.Comp.MultiParam.Term+ , module Data.Comp.MultiParam.Algebra+ , module Data.Comp.MultiParam.HDifunctor+ , module Data.Comp.MultiParam.Sum+ , module Data.Comp.MultiParam.Annotation+ , module Data.Comp.MultiParam.Equality+ ) where++import Data.Comp.MultiParam.Term+import Data.Comp.MultiParam.Algebra+import Data.Comp.MultiParam.HDifunctor+import Data.Comp.MultiParam.Sum+import Data.Comp.MultiParam.Annotation+import Data.Comp.MultiParam.Equality
+ src/Data/Comp/MultiParam/Algebra.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators,+ FlexibleContexts, CPP #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Algebra+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the notion of algebras and catamorphisms, and their+-- generalizations to e.g. monadic versions and other (co)recursion schemes.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Algebra (+ -- * Algebras & Catamorphisms+ Alg,+ free,+ cata,+ cata',+ appCxt,+ + -- * Monadic Algebras & Catamorphisms+ AlgM,+-- algM,+ freeM,+ cataM,+ AlgM',+ Compose(..),+ freeM',+ cataM',++ -- * Term Homomorphisms+ CxtFun,+ SigFun,+ TermHom,+ appTermHom,+ appTermHom',+ compTermHom,+ appSigFun,+ appSigFun',+ compSigFun,+ termHom,+ compAlg,++ -- * Monadic Term Homomorphisms+ CxtFunM,+ SigFunM,+ TermHomM,+ sigFunM,+ termHom',+ appTermHomM,+ appTermHomM',+ termHomM,+ appSigFunM,+ appSigFunM',+ compTermHomM,+ 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++import Unsafe.Coerce (unsafeCoerce)++{-| 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 (Term t) = f (hfmap run t)+ run (Hole x) = g x+ run (Place 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 = run . coerceCxt+ where run :: Trm f a :-> a+ run (Term t) = f (hfmap run t)+ run (Place 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 (Term t) = Term (hfmap appCxt t)+appCxt (Hole x) = x+appCxt (Place p) = Place 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 m a, 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 (Term t) = f =<< hdimapM run t+ run (Hole x) = g x+ run (Place p) = return p++{-| Construct a monadic catamorphism from the given monadic algebra. -}+cataM :: forall m f a. (HDitraversable f m a, Monad m)+ => AlgM m f a -> NatM m (Term f) a+{-# NOINLINE [1] cataM #-}+cataM algm = run . coerceCxt+ where run :: NatM m (Trm f a) a+ run (Term t) = algm =<< hdimapM run t+ run (Place 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 (Term t) = f $ hfmap (Compose . run) t+ run (Hole x) = g x+ run (Place 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 = run . coerceCxt+ where run :: NatM m (Trm f a) a+ run (Term t) = algm $ hfmap (Compose . run) t+ run (Place 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 TermHom f g = SigFun f (Context g)++{-| Apply a term homomorphism recursively to a term/context. -}+appTermHom :: forall f g. (HDifunctor f, HDifunctor g)+ => TermHom f g -> CxtFun f g+{-# INLINE [1] appTermHom #-}+appTermHom f = run where+ run :: CxtFun f g+ run (Term t) = appCxt (f (hfmap run t))+ run (Hole x) = Hole x+ run (Place p) = Place p++-- | Apply a term homomorphism recursively to a term/context. This is+-- a top-down variant of 'appTermHom'.+appTermHom' :: forall f g. (HDifunctor g)+ => TermHom f g -> CxtFun f g+{-# INLINE [1] appTermHom' #-}+appTermHom' f = run where+ run :: CxtFun f g+ run (Term t) = appCxt (hfmapCxt run (f t))+ run (Hole x) = Hole x+ run (Place p) = Place p++{-| Compose two term homomorphisms. -}+compTermHom :: (HDifunctor g, HDifunctor h)+ => TermHom g h -> TermHom f g -> TermHom f h+compTermHom f g = appTermHom f . g++{-| Compose an algebra with a term homomorphism to get a new algebra. -}+compAlg :: (HDifunctor f, HDifunctor g) => Alg g a -> TermHom 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 (Term t) = Term (f (hfmap run t))+ run (Hole x) = Hole x+ run (Place p) = Place 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 (Term t) = Term (hfmap run (f t))+ run (Hole x) = Hole x+ run (Place p) = Place 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. -}+termHom :: HDifunctor g => SigFun f g -> TermHom f g+termHom 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 context function. -}+type CxtFunM' m f g = forall h b . NatM m (Cxt h f Any b) (Cxt h g Any b)+++coerceCxtFunM :: CxtFunM' m f g -> CxtFunM m f g+coerceCxtFunM = unsafeCoerce+++{-| This type represents a monadic term homomorphism. -}+type TermHomM 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. -}+termHom' :: (HDifunctor f, HDifunctor g, Monad m)+ => SigFunM m f g -> TermHomM m f g+termHom' f = liftM (Term . hfmap Hole) . f++{-| Lift the given signature function to a monadic term homomorphism. -}+termHomM :: (HDifunctor g, Monad m) => SigFun f g -> TermHomM m f g+termHomM f = sigFunM $ termHom f++{-| Apply a monadic term homomorphism recursively to a term/context. -}+appTermHomM :: forall f g m. (HDitraversable f m Any, HDifunctor g, Monad m)+ => TermHomM m f g -> CxtFunM m f g+{-# NOINLINE [1] appTermHomM #-}+appTermHomM f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM appCxt (f =<< hdimapM run t)+ run (Hole x) = return (Hole x)+ run (Place p) = return (Place p)++-- | Apply a monadic term homomorphism recursively to a+-- term/context. This is a top-down variant of 'appTermHomM'.+appTermHomM' :: forall f g m. (HDitraversable g m Any, Monad m)+ => TermHomM m f g -> CxtFunM m f g+{-# NOINLINE [1] appTermHomM' #-}+appTermHomM' f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM appCxt (hdimapMCxt run =<< f t)+ run (Hole x) = return (Hole x)+ run (Place p) = return (Place p)+++{-| This function applies a monadic signature function to the given context. -}+appSigFunM :: forall m f g. (HDitraversable f m Any, Monad m)+ => SigFunM m f g -> CxtFunM m f g+appSigFunM f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM Term (f =<< hdimapM run t)+ run (Hole x) = return (Hole x)+ run (Place p) = return (Place p)++-- | 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 m Any, Monad m)+ => SigFunM m f g -> CxtFunM m f g+appSigFunM' f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM Term (hdimapM run =<< f t)+ run (Hole x) = return (Hole x)+ run (Place p) = return (Place p)+++{-| Compose two monadic term homomorphisms. -}+compTermHomM :: (HDitraversable g m Any, HDifunctor h, Monad m)+ => TermHomM m g h -> TermHomM m f g -> TermHomM m f h+compTermHomM f g = appTermHomM f <=< g++{-| Compose a monadic algebra with a monadic term homomorphism to get a new+ monadic algebra. -}+compAlgM :: (HDitraversable g m a, Monad m)+ => AlgM m g a -> TermHomM 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 m a, Monad m) => AlgM m g a+ -> TermHom 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/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) x.+ cata a (appTermHom h x) = cata (compAlg a h) x;++ "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;+ #-}++{-+{-# RULES + "cataM/appTermHomM" forall (a :: AlgM m g d) (h :: TermHomM m f g d) x.+ appTermHomM h x >>= cataM a = cataM (compAlgM a h) x;++ "cataM/appTermHom" forall (a :: AlgM m g d) (h :: TermHom f g) x.+ cataM a (appTermHom h x) = cataM (compAlgM' a h) x;++ "appTermHomM/appTermHomM" forall (a :: TermHomM m g h b) (h :: TermHomM m f g b) x.+ appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;+ #-}++{-# RULES+ "cata/build" forall alg (g :: forall a . Alg f a -> a) .+ cata alg (build g) = g alg+ #-}+-}+#endif
+ src/Data/Comp/MultiParam/Annotation.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,+ UndecidableInstances, RankNTypes, GADTs, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Annotation+-- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines annotations on signatures.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Annotation+ (+ (:&:) (..),+ (:*:) (..),+ DistAnn (..),+ RemA (..),+ liftA,+ liftA',+ stripA,+ propAnn,+ propAnnM,+ ann,+ project'+ ) where++import qualified Data.Comp.Ops as O+import Data.Comp.MultiParam.HDifunctor+import Data.Comp.MultiParam.Term+import Data.Comp.MultiParam.Sum+import Data.Comp.MultiParam.Ops+import Data.Comp.MultiParam.Algebra++import Control.Monad++{-| Transform a function with a domain constructed from a higher-order difunctor+ to a function with a domain constructed with the same higher-order difunctor,+ but with an additional annotation. -}+liftA :: (RemA s s') => (s' a b :-> t) -> s a b :-> t+liftA f v = f (remA v)++{-| Transform a function with a domain constructed from a higher-order difunctor+ to a function with a domain constructed with the same higher-order difunctor,+ but with an additional annotation. -}+liftA' :: (DistAnn s' p s, HDifunctor s')+ => (s' a b :-> Cxt h s' c d) -> s a b :-> Cxt h s c d+liftA' f v = let v' O.:&: p = projectA v+ in ann p (f v')++{-| Strip the annotations from a term over a higher-order difunctor with+ annotations. -}+stripA :: (RemA g f, HDifunctor g) => CxtFun g f+stripA = appSigFun remA++{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism+ over the same signatures, but extended with annotations. -}+propAnn :: (DistAnn f p f', DistAnn g p g', HDifunctor g) + => TermHom f g -> TermHom 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)+ => TermHomM m f g -> TermHomM 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. -}+-- bug in type checker? below is the inferred type, however, the type checker+-- rejects it.+-- project' :: (RemA f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))+project' v = liftM remA $ project v
+ src/Data/Comp/MultiParam/Any.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE EmptyDataDecls, KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Any+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the empty data type 'Any', which is used to emulate+-- parametricity (\"poor mans parametricity\").+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Any+ (+ Any+ ) where++-- |The empty data type 'Any' is used to emulate parametricity+-- (\"poor mans parametricity\").+data Any :: * -> *
+ src/Data/Comp/MultiParam/Derive.hs view
@@ -0,0 +1,51 @@+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module contains functionality for automatically deriving boilerplate+-- code using Template Haskell. Examples include instances of 'HDifunctor',+-- 'ShowHD', and 'EqHD'.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Derive+ (+ derive,+ -- |Derive boilerplate instances for parametric signatures, i.e.+ -- signatures for parametric compositional data types.++ -- ** EqHD+ module Data.Comp.MultiParam.Derive.Equality,+ -- ** OrdHD+ module Data.Comp.MultiParam.Derive.Ordering,+ -- ** ShowHD+ module Data.Comp.MultiParam.Derive.Show,+ -- ** HDifunctor+ module Data.Comp.MultiParam.Derive.HDifunctor,+ -- ** HFoldable+ module Data.Comp.Multi.Derive.Foldable,+ -- ** HTraversable+ module Data.Comp.Multi.Derive.Traversable,+ -- ** Smart Constructors+ module Data.Comp.MultiParam.Derive.SmartConstructors,+ -- ** Smart Constructors w/ Annotations+ module Data.Comp.MultiParam.Derive.SmartAConstructors,+ -- ** Lifting to Sums+ module Data.Comp.MultiParam.Derive.LiftSum+ ) where++import Data.Comp.Derive.Utils (derive)+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.Multi.Derive.Foldable+import Data.Comp.Multi.Derive.Traversable+import Data.Comp.MultiParam.Derive.SmartConstructors+import Data.Comp.MultiParam.Derive.SmartAConstructors+import Data.Comp.MultiParam.Derive.LiftSum
+ src/Data/Comp/MultiParam/Derive/Equality.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,+ ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.Equality+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @EqHD@.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam.Derive.Equality+ (+ EqHD(..),+ makeEqHD+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.MultiParam.FreshM+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)+ return [InstanceD [] 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 ->+ [| do {v <- genVar;+ peq ($(varE x) $ varCoerce v) + ($(varE y) $ varCoerce v)} |]+ SigT tp' _ ->+ eqHDB conArg coArg (x, y, tp')+ _ ->+ if containsType tp (VarT conArg) then+ [| eqHD $(varE x) $(varE y) |]+ else+ [| peq $(varE x) $(varE y) |]
+ src/Data/Comp/MultiParam/Derive/HDifunctor.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.HDifunctor+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @HDifunctor@.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Derive.HDifunctor+ (+ HDifunctor,+ makeHDifunctor+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.MultiParam.HDifunctor+import Language.Haskell.TH++{-| Derive an instance of 'HDifunctor' for a type constructor of any parametric+ kind taking at least three arguments. -}+makeHDifunctor :: Name -> Q [Dec]+makeHDifunctor fname = do+ TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+ let args' = init args+ -- covariant argument+ let coArg :: Name = tyVarBndrName $ last args'+ -- contravariant argument+ let conArg :: Name = tyVarBndrName $ last $ init args'+ let argNames = map (VarT . tyVarBndrName) (init $ init args')+ let complType = foldl AppT (ConT name) argNames+ let classType = AppT (ConT ''HDifunctor) complType+ constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+ hdimapDecl <- funD 'hdimap (map (hdimapClause conArg coArg) constrs')+ return [InstanceD [] classType [hdimapDecl]]+ where hdimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ+ hdimapClause conArg coArg (constr, args) = do+ fn <- newName "_f"+ gn <- newName "_g"+ varNs <- newNames (length args) "x"+ let f = varE fn+ let g = varE gn+ let fp = VarP fn+ let gp = VarP gn+ -- Pattern for the constructor+ let pat = ConP constr $ map VarP varNs+ body <- hdimapArgs conArg coArg f g (zip varNs args) (conE constr)+ return $ Clause [fp, gp, pat] (NormalB body) []+ hdimapArgs :: Name -> Name -> ExpQ -> ExpQ+ -> [(Name, Type)] -> ExpQ -> ExpQ+ hdimapArgs _ _ _ _ [] acc =+ acc+ hdimapArgs conArg coArg f g ((x,tp):tps) acc =+ hdimapArgs conArg coArg f g tps+ (acc `appE` (hdimapArg conArg coArg tp f g `appE` varE x))+ hdimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ+ hdimapArg conArg coArg tp f g+ | not (containsType tp (VarT conArg)) &&+ not (containsType tp (VarT coArg)) = [| id |]+ | otherwise =+ case tp of+ AppT (VarT a) _ | a == conArg -> f+ | a == coArg -> g+ AppT (AppT ArrowT tp1) tp2 -> do+ xn <- newName "x"+ let ftp1 = hdimapArg conArg coArg tp1 f g+ let ftp2 = hdimapArg conArg coArg tp2 f g+ lamE [varP xn]+ (infixE (Just ftp2)+ [|(.)|]+ (Just $ infixE (Just $ varE xn)+ [|(.)|]+ (Just ftp1)))+ SigT tp' _ ->+ hdimapArg conArg coArg tp' f g+ _ ->+ if containsType tp (VarT conArg) then+ [| hdimap $f $g |]+ else+ [| fmap $g |]
+ src/Data/Comp/MultiParam/Derive/Injections.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.Injections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature injections.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Derive.Injections+ (+ injn,+ injectn,+ deepInjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.MultiParam.HDifunctor+import Data.Comp.MultiParam.Term+import Data.Comp.MultiParam.Algebra (CxtFun, appSigFun)+import Data.Comp.MultiParam.Ops ((:+:)(..), (:<:)(..))++injn :: Int -> Q [Dec]+injn n = do+ let i = mkName $ "inj" ++ show n+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let bvar = mkName "b"+ let ivar = mkName "i"+ let xvar = mkName "x"+ let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar bvar ivar) : d+ where genSig fvars gvar avar bvar ivar = do+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = arrowT `appT` (tp `appT` varT avar `appT`+ varT bvar `appT` varT ivar)+ `appT` (varT gvar `appT` varT avar `appT`+ varT bvar `appT` varT ivar)+ forallT (map PlainTV $ gvar : avar : bvar : ivar : fvars)+ (sequence cxt) tp'+ genDecl x n = [| case $(varE x) of+ Inl x -> $(varE $ mkName $ "inj") x+ Inr x -> $(varE $ mkName $ "inj" +++ if n > 2 then show (n - 1) else "") x |]+injectn :: Int -> Q [Dec]+injectn n = do+ let i = mkName ("inject" ++ show n)+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let bvar = mkName "b"+ let ivar = mkName "i"+ let d = [funD i [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar bvar ivar) : d+ where genSig fvars gvar avar bvar ivar = do+ let hvar = mkName "h"+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar+ `appT` varT avar `appT` varT bvar+ let tp'' = arrowT `appT` (tp `appT` varT avar `appT`+ tp' `appT` varT ivar)+ `appT` (tp' `appT` varT ivar)+ forallT (map PlainTV $ hvar : gvar : avar : bvar : ivar : fvars)+ (sequence cxt) tp''+ genDecl n = [| 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 ''HDifunctor [tp]+ let tp' = conT ''CxtFun `appT` tp `appT` varT gvar+ forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
+ src/Data/Comp/MultiParam/Derive/LiftSum.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.LiftSum+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Lift a class declaration for higher-order difunctors to sums of higher-order+-- difunctors.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Derive.LiftSum+ (+ liftSum,+ caseHD+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.MultiParam.Sum+import Data.Comp.MultiParam.Ops ((:+:)(..))++{-| 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 fname = do+ ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname+ let targs' = map tyVarBndrName $ tail targs+ let f = mkName "f"+ let g = mkName "g"+ let cxt = [ClassP name (map VarT $ f : targs'),+ ClassP name (map VarT $ g : targs')]+ let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)+ let complType = foldl (\a x -> a `AppT` VarT x) tp targs'+ decs' <- sequence $ concatMap decl decs+ return [InstanceD cxt complType decs']+ where decl :: Dec -> [DecQ]+ decl (SigD f _) = [funD f [clause f]]+ decl _ = []+ clause :: Name -> ClauseQ+ clause f = do x <- newName "x"+ b <- normalB [|caseHD $(varE f) $(varE f) $(varE x)|]+ return $ Clause [VarP x] b []++{-| 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
+ src/Data/Comp/MultiParam/Derive/Ordering.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,+ ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.Ordering+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @OrdHD@.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam.Derive.Ordering+ (+ OrdHD(..),+ makeOrdHD+ ) where++import Data.Comp.MultiParam.FreshM+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')+ return [InstanceD [] 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 ->+ [| do {v <- genVar;+ pcompare ($(varE x) $ varCoerce v)+ ($(varE y) $ varCoerce v)} |]+ SigT tp' _ ->+ eqDB conArg coArg (x, y, tp')+ _ ->+ if containsType tp (VarT conArg) then+ [| compareHD $(varE x) $(varE y) |]+ else+ [| pcompare $(varE x) $(varE y) |]+ genLtClause (c, _) (d, _) =+ clause [recP c [], recP d []] (normalB [| return LT |]) []+ genGtClause (c, _) (d, _) =+ clause [recP c [], recP d []] (normalB [| return GT |]) []
+ src/Data/Comp/MultiParam/Derive/Projections.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE TemplateHaskell, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.Projections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature projections.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Derive.Projections+ (+ projn,+ projectn,+ deepProjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Control.Monad (liftM)+import Data.Comp.MultiParam.HDitraversable (HDitraversable)+import Data.Comp.MultiParam.Term+import Data.Comp.MultiParam.Algebra (CxtFunM, appSigFunM')+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+ Place _ -> 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 ''HDitraversable [tp, conT ''Maybe, conT ''Any]+ let tp' = conT ''CxtFunM `appT` conT ''Maybe+ `appT` varT fvar `appT` tp+ forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
+ src/Data/Comp/MultiParam/Derive/Show.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,+ ScopedTypeVariables, UndecidableInstances, KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.Show+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @ShowHD@.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam.Derive.Show+ (+ PShow(..),+ ShowHD(..),+ makeShowHD+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.MultiParam.FreshM+import Control.Monad+import Language.Haskell.TH hiding (Cxt, match)++-- |Printing of parametric values.+class PShow a where+ pshow :: a i -> FreshM String++{-| Signature printing. An instance @ShowHD f@ gives rise to an instance+ @Show (Term f i)@. -}+class ShowHD f where+ showHD :: PShow a => f Var a i -> FreshM String++{-| 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')+ return [InstanceD [] 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 -> [| pshow $(varE x) |]+ AppT (AppT ArrowT (AppT (VarT a) _)) _+ | a == conArg ->+ [| do {v <- genVar;+ body <- pshow $ $(varE x) v;+ return $ "\\" ++ varShow v ++ " -> " ++ body} |]+ SigT tp' _ ->+ showHDB conArg coArg (x, tp')+ _ ->+ if containsType tp (VarT conArg) then+ [| showHD $(varE x) |]+ else+ [| pshow $(varE x) |]
+ src/Data/Comp/MultiParam/Derive/SmartAConstructors.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.SmartAConstructors+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive smart constructors with annotations.+--+--------------------------------------------------------------------------------++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 Control.Monad++{-| Derive smart constructors with products for a type constructor of any+ parametric kind taking at least three arguments. The smart constructors are+ similar to the ordinary constructors, but an 'injectA' 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|] $ foldl appE (conE name) vars+ function = [funD sname [clause pats (normalB [|Term $val|]) []]]+ sequence function
+ src/Data/Comp/MultiParam/Derive/SmartConstructors.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Derive.SmartConstructors+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive smart constructors for parametric types.+--+--------------------------------------------------------------------------------++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 Control.Monad++{-| Derive smart constructors for a type constructor of any parametric kind+ taking at least three 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+ let iVar = tyVarBndrName $ last targs+ let cons = map (\con -> (abstractConType con, iTp iVar con)) 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 $val|]) []]]+ sequence $ sig ++ function+ genSig targs tname sname 0 miTp = (:[]) $ do+ hvar <- newName "h"+ fvar <- newName "f"+ avar <- newName "a"+ bvar <- newName "b"+ ivar <- newName "i"+ let targs' = init $ init $ init $ targs+ vars = hvar:fvar:avar:bvar:(maybe [ivar] (const []) miTp)++targs'+ h = varT hvar+ f = varT fvar+ a = varT avar+ b = varT bvar+ i = varT ivar+ ftype = foldl appT (conT tname) (map varT targs')+ constr = classP ''(:<:) [ftype, f]+ typ = foldl appT (conT ''Cxt) [h, f, a, b,maybe i return miTp]+ typeSig = forallT (map PlainTV vars) (sequence [constr]) typ+ sigD sname typeSig+ genSig _ _ _ _ _ = []
+ src/Data/Comp/MultiParam/Desugar.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,+ UndecidableInstances, OverlappingInstances, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Desugar+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This modules defines the 'Desugar' type class for desugaring of terms.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Desugar where++import Data.Comp.MultiParam+import Data.Comp.MultiParam.Derive++-- |The desugaring term homomorphism.+class (HDifunctor f, HDifunctor g) => Desugar f g where+ desugHom :: TermHom f g+ desugHom = desugHom' . hfmap Hole+ desugHom' :: f a (Cxt h g a b) :-> Cxt h g a b+ desugHom' x = appCxt (desugHom x)++$(derive [liftSum] [''Desugar])++-- |Desugar a term.+desugar :: Desugar f g => Term f :-> Term g+desugar = appTermHom desugHom++-- |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 = appTermHom (propAnn desugHom)++-- |Default desugaring instance.+instance (HDifunctor f, HDifunctor g, f :<: g) => Desugar f g where+ desugHom = simpCxt . inj
+ src/Data/Comp/MultiParam/Equality.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,+ UndecidableInstances, IncoherentInstances, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Equality+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines equality for signatures, which lifts to equality for+-- terms.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam.Equality+ (+ PEq(..),+ EqHD(..)+ ) where++import Data.Comp.MultiParam.Term+import Data.Comp.MultiParam.Sum+import Data.Comp.MultiParam.Ops+import Data.Comp.MultiParam.HDifunctor+import Data.Comp.MultiParam.FreshM++-- |Equality on parametric values. The equality test is performed inside the+-- 'FreshM' monad for generating fresh identifiers.+class PEq a where+ peq :: a i -> a j -> FreshM Bool++instance Eq a => PEq (K a) where+ peq (K x) (K y) = return $ x == y++{-| Signature equality. An instance @EqHD f@ gives rise to an instance+ @Eq (Term f i)@. The equality test is performed inside the 'FreshM' monad for+ generating fresh identifiers. -}+class EqHD f where+ eqHD :: PEq a => f Var a i -> f Var 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 Var where+ peq x y = return $ varEq 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 (Term e1) (Term e2) = eqHD e1 e2+ eqHD (Hole h1) (Hole h2) = peq h1 h2+ eqHD (Place p1) (Place p2) = peq p1 p2+ eqHD _ _ = return False++instance (EqHD f, PEq a) => PEq (Cxt h f Var a) where+ peq = eqHD++{-| Equality on terms. -}+instance (HDifunctor f, EqHD f) => Eq (Term f i) where+ (==) x y = evalFreshM $ eqHD (coerceCxt x) (coerceCxt y)
+ src/Data/Comp/MultiParam/FreshM.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.FreshM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines a monad for generating fresh, abstract variables, useful+-- e.g. for defining equality on terms.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam.FreshM+ (+ FreshM,+ Var,+ varEq,+ varCompare,+ varShow,+ genVar,+ varCoerce,+ evalFreshM+ ) where++import Control.Monad.State++-- |Monad for generating fresh (abstract) variables.+newtype FreshM a = FreshM (State [String] a)+ deriving Monad++-- |Abstract notion of a variable (the constructor is hidden).+data Var i = Var String++-- |Equality on variables.+varEq :: Var i -> Var j -> Bool+varEq (Var x) (Var y) = x == y++-- |Ordering of variables.+varCompare :: Var i -> Var j -> Ordering+varCompare (Var x) (Var y) = compare x y++-- |Printing of variables.+varShow :: Var i -> String+varShow (Var x) = x++-- |Change the type of a variable.+varCoerce :: Var i -> Var j+varCoerce (Var x) = Var x++-- |Generate a fresh variable.+genVar :: FreshM (Var i)+genVar = FreshM $ do xs <- get+ case xs of+ (x : xs') -> do {put xs'; return $ Var x}+ _ -> fail "Unexpected empty list"++-- |Evaluate a computation that uses fresh variables.+evalFreshM :: FreshM a -> a+evalFreshM (FreshM m) = evalState m vars+ where baseVars = ['a'..'z']+ vars = map (:[]) baseVars ++ vars' 1+ vars' n = map (: show n) baseVars ++ vars' (n + 1)
+ src/Data/Comp/MultiParam/HDifunctor.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, RankNTypes,+ TypeOperators, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.HDifunctor+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines higher-order difunctors, a hybrid between higher-order+-- functors (Johann, Ghani, POPL '08), and difunctors (Meijer, Hutton, FPCA+-- '95). Higher-order difunctors are used to define signatures for+-- compositional parametric generalised data types.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.HDifunctor+ (+ HDifunctor (..),+ HFunctor (..),+ I (..),+ K (..),+ A (..),+ (:->),+ NatM+ ) where++import Data.Comp.Multi.Functor (HFunctor (..))++-- | The identity functor.+data I a = I {unI :: a}++-- | The parametrised constant functor.+data K a i = K {unK :: a}++instance Functor I where+ fmap f (I x) = I (f x)++instance Functor (K a) where+ fmap _ (K x) = K x++data A f = forall i. A {unA :: f i}++instance Eq a => Eq (K a i) where+ K x == K y = x == y+ K x /= K y = x /= y++instance Ord a => Ord (K a i) where+ K x < K y = x < y+ K x > K y = x > y+ K x <= K y = x <= y+ K x >= K y = x >= y+ min (K x) (K y) = K $ min x y+ max (K x) (K y) = K $ max x y+ compare (K x) (K y) = compare x y++infixr 0 :-> -- same precedence as function space operator ->++-- |This type represents natural transformations.+type f :-> g = forall i . f i -> g i++-- |This type represents monadic natural transformations.+type NatM m f g = forall i. f i -> m (g i)++-- | This class represents higher-order difunctors.+class HDifunctor f where+ hdimap :: (a :-> b) -> (c :-> d) -> f b c :-> f a d++-- |A higher-order difunctor gives rise to a higher-order functor when+-- restricted to a particular contravariant argument.+instance HDifunctor f => HFunctor (f a) where+ hfmap = hdimap id
+ src/Data/Comp/MultiParam/HDitraversable.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses,+ FlexibleContexts, OverlappingInstances, TypeOperators, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.HDitraversable+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines traversable higher-order difunctors.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.HDitraversable+ (+ HDitraversable (..),+ HTraversable (..)+ ) where++import Prelude hiding (mapM, sequence, foldr)+import Data.Comp.Multi.Traversable+import Data.Comp.MultiParam.HDifunctor+{-import Data.Traversable+import Test.QuickCheck.Gen+import Data.Functor.Identity+import Control.Monad.Reader hiding (mapM, sequence)-}++{-| HDifunctors representing data structures that can be traversed from left to+ right. -}+class (HDifunctor f, Monad m) => HDitraversable f m a where+ hdimapM :: NatM m b c -> NatM m (f a b) (f a c)++{-| If a higher-order difunctor is 'HTraversable' for a given contravariant+ argument @a@, then it is 'HDitraversable' for all 'Monad's @m@ with the same+ @a@. -}+instance (HDifunctor f, Monad m, HTraversable (f a)) => HDitraversable f m a where+ hdimapM = hmapM++{-instance HDitraversable (:~>) Gen a where+ hdimapM f ((:~>) s) = MkGen run+ where run stdGen seed a = unGen (f (s a)) stdGen seed++instance HDitraversable (->) Identity a where+ dimapM f s = Identity run+ where run a = runIdentity (f (s a))+ disequence s = Identity run+ where run a = runIdentity (s a)++instance HDitraversable (->) m a => HDitraversable (->) (ReaderT r m) a where+ dimapM f s = ReaderT (disequence . run)+ where run r a = runReaderT (f (s a)) r+ disequence s = ReaderT (disequence . run)+ where run r a = runReaderT (s a) r++{-| Functions of the type @Any -> Maybe a@ can be turned into functions of+ type @Maybe (Any -> a)@. The empty type @Any@ ensures that the function+ is parametric in the input, and hence the @Maybe@ monad can be pulled out. -}+instance HDitraversable (->) Maybe Any where+ disequence f = do _ <- f undefined+ return $ \x -> fromJust $ f x-}
+ src/Data/Comp/MultiParam/Ops.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies,+ FlexibleInstances, UndecidableInstances, IncoherentInstances,+ KindSignatures #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Ops+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module provides operators on higher-order difunctors.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Ops where++import Data.Comp.MultiParam.HDifunctor+import Data.Comp.MultiParam.HDitraversable+import qualified Data.Comp.Ops as O+import Control.Monad (liftM)+++-- Sums+infixr 6 :+:++-- |Formal sum of signatures (difunctors).+data (f :+: g) (a :: * -> *) (b :: * -> *) i = Inl (f a b i)+ | Inr (g a b i)++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 m a, HDitraversable g m a)+ => HDitraversable (f :+: g) m a 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 m a => HDitraversable (f :&: p) m a where+ hdimapM f (v :&: c) = liftM (:&: c) (hdimapM f v)++{-| This class defines how to distribute an annotation over a sum of+ signatures. -}+class DistAnn (s :: (* -> *) -> (* -> *) -> * -> *) p s' | s' -> s, s' -> p where+ {-| Inject an annotation over a signature. -}+ injectA :: p -> s a b :-> s' a b+ {-| Project an annotation from a signature. -}+ projectA :: s' a b :-> (s a b O.:&: p)++class RemA (s :: (* -> *) -> (* -> *) -> * -> *) s' | s -> s' where+ {-| Remove annotations from a signature. -}+ remA :: s a b :-> s' a b++instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where+ remA (Inl (v :&: _)) = Inl v+ remA (Inr v) = Inr $ remA v++instance RemA (f :&: p) f where+ remA (v :&: _) = v++instance DistAnn f p (f :&: p) where+ injectA c v = v :&: c++ projectA (v :&: p) = v O.:&: p++instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where+ injectA c (Inl v) = Inl (v :&: c)+ injectA c (Inr v) = Inr $ injectA c v++ projectA (Inl (v :&: p)) = Inl v O.:&: p+ projectA (Inr v) = let (v' O.:&: p) = projectA v+ in Inr v' O.:&: p
+ src/Data/Comp/MultiParam/Ordering.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,+ UndecidableInstances, IncoherentInstances, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Ordering+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines ordering of signatures, which lifts to ordering of+-- terms and contexts.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam.Ordering+ (+ POrd(..),+ OrdHD(..)+ ) where++import Data.Comp.MultiParam.Term+import Data.Comp.MultiParam.Sum+import Data.Comp.MultiParam.Ops+import Data.Comp.MultiParam.HDifunctor+import Data.Comp.MultiParam.FreshM+import Data.Comp.MultiParam.Equality++-- |Ordering of parametric values.+class PEq a => POrd a where+ pcompare :: a i -> a j -> FreshM Ordering++instance Ord a => POrd (K a) where+ pcompare (K x) (K y) = return $ compare x y++{-| Signature ordering. An instance @OrdHD f@ gives rise to an instance+ @Ord (Term f)@. -}+class EqHD f => OrdHD f where+ compareHD :: POrd a => f Var a i -> f Var 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 (Term e1) (Term e2) = compareHD e1 e2+ compareHD (Hole h1) (Hole h2) = pcompare h1 h2+ compareHD (Place p1) (Place p2) = pcompare p1 p2+ compareHD (Term _) _ = return LT+ compareHD (Hole _) (Term _) = return GT+ compareHD (Hole _) (Place _) = return LT+ compareHD (Place _) _ = return GT++instance POrd Var where+ pcompare x y = return $ varCompare x y++instance (OrdHD f, POrd a) => POrd (Cxt h f Var a) where+ pcompare = compareHD++{-| Ordering of terms. -}+instance (HDifunctor f, OrdHD f) => Ord (Term f i) where+ compare x y = evalFreshM $ compareHD (coerceCxt x) (coerceCxt y)
+ src/Data/Comp/MultiParam/Show.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances,+ IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Show+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines showing of signatures, which lifts to showing of terms.+--+--------------------------------------------------------------------------------+module Data.Comp.MultiParam.Show+ (+ PShow(..),+ 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++instance Show a => PShow (K a) where+ pshow = return . show . unK++-- Lift ShowHD to sums+$(derive [liftSum] [''ShowHD])++instance PShow Var where+ pshow = return . varShow++{-| From an 'ShowHD' higher-order difunctor an 'ShowHD' instance of the+ corresponding term type can be derived. -}+instance (ShowHD f, PShow a) => PShow (Cxt h f Var a) where+ pshow (Term t) = showHD t+ pshow (Hole h) = pshow h+ pshow (Place p) = pshow p++{-| Printing of terms. -}+instance (HDifunctor f, ShowHD f) => Show (Term f i) where+ show = evalFreshM . pshow .+ (coerceCxt :: Term f i -> Trm f Var i)++instance (ShowHD f, PShow (K p)) => ShowHD (f :&: p) where+ showHD (x :&: p) = do sx <- showHD x+ sp <- pshow $ K p+ return $ sx ++ " :&: " ++ sp
+ src/Data/Comp/MultiParam/Sum.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,+ FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,+ ScopedTypeVariables, TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Sum+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module provides the infrastructure to extend signatures.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Sum+ (+ (:<:),+ (:+:),++ -- * 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,++ -- * Injections and Projections for Constants+ injectConst,+ injectConst2,+ injectConst3,+ projectConst,+ 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 (Term t) = proj t+project (Hole _) = Nothing+project (Place _) = 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 Maybe Any, g :<: f) => CxtFunM Maybe f g+{-# 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 a (Cxt h f a b) :-> Cxt h f a b+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/+-- 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 #-}++{-{-| A variant of 'proj' for binary sum signatures. -}+proj2 :: forall f g1 g2 a b i. (g1 :<: f, g2 :<: f) => f a b i+ -> Maybe ((g1 :+: g2) a b i)+proj2 x = case proj x of+ Just (y :: g1 a b i) -> Just $ inj y+ _ -> liftM inj (proj x :: Maybe (g2 a b i))++{-| A variant of 'proj' for ternary sum signatures. -}+proj3 :: forall f g1 g2 g3 a b i. (g1 :<: f, g2 :<: f, g3 :<: f) => f a b i+ -> Maybe ((g1 :+: g2 :+: g3) a b i)+proj3 x = case proj x of+ Just (y :: g1 a b i) -> Just $ inj y+ _ -> case proj x of+ Just (y :: g2 a b i) -> Just $ inj y+ _ -> liftM inj (proj x :: Maybe (g3 a b i))++-- |Project the outermost layer of a term to a sub signature.+project :: (g :<: f) => NatM Maybe (Cxt h f a b) (g a (Cxt h f a b))+project (Term t) = proj t+project (Hole _) = Nothing+project (Place _) = Nothing++-- |Project the outermost layer of a term to a binary sub signature.+project2 :: (g1 :<: f, g2 :<: f)+ => NatM Maybe (Cxt h f a b) ((g1 :+: g2) a (Cxt h f a b))+project2 (Term t) = proj2 t+project2 (Hole _) = Nothing+project2 (Place _) = Nothing++-- |Project the outermost layer of a term to a ternary sub signature.+project3 :: (g1 :<: f, g2 :<: f, g3 :<: f)+ => NatM Maybe (Cxt h f a b) ((g1 :+: g2 :+: g3) a (Cxt h f a b))+project3 (Term t) = proj3 t+project3 (Hole _) = Nothing+project3 (Place _) = Nothing++-- | Tries to coerce a term/context to a term/context over a+-- sub-signature.+deepProject :: (HDitraversable g Maybe Any, g :<: f)+ => CxtFunM Maybe f g+deepProject = appSigFunM' proj++-- | This is a variant of 'deepProject' that can be used if the target+-- signature cannot be derived as being a sub-signature of the source+-- signature directly but its decomposition into two summands can.+deepProject2 :: (HDitraversable (g1 :+: g2) Maybe Any, g1 :<: f, g2 :<: f)+ => CxtFunM Maybe f (g1 :+: g2)+deepProject2 = appSigFunM' proj2++-- | This is a variant of 'deepProject' that can be used if the target+-- signature cannot be derived as being a sub-signature of the source+-- signature directly but its decomposition into three summands can.+deepProject3 ::(HDitraversable (g1 :+: g2 :+: g3) Maybe Any, g1 :<: f, g2 :<: f, g3 :<: f)+ => CxtFunM Maybe f (g1 :+: g2 :+: g3)+deepProject3 = appSigFunM' proj3++{-| A variant of 'inj' for binary sum signatures. -}+inj2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a b :-> g a b+inj2 (Inl x) = inj x+inj2 (Inr y) = inj y++{-| A variant of 'inj' for ternary sum signatures. -}+inj3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a b :-> g a b+inj3 (Inl x) = inj x+inj3 (Inr y) = inj2 y++-- |Inject a term where the outermost layer is a sub signature.+inject :: (g :<: f) => g a (Cxt h f a b) :-> Cxt h f a b+inject = Term . inj++-- |Inject a term where the outermost layer is a binary sub signature.+inject2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a (Cxt h g a b) :-> Cxt h g a b+inject2 = Term . inj2++-- |Inject a term where the outermost layer is a ternary sub signature.+inject3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a (Cxt h g a b)+ :-> Cxt h g a b+inject3 = Term . inj3++-- |Inject a term over a sub signature to a term over larger signature.+deepInject :: (HDifunctor g, g :<: f) => CxtFun g f+deepInject = appSigFun inj++-- |Inject a term over a binary sub signature to a term over larger signature.+deepInject2 :: (HDifunctor (f1 :+: f2), f1 :<: g, f2 :<: g) => CxtFun (f1 :+: f2) g+deepInject2 = appSigFun inj2++-- |Inject a term over a ternary signature to a term over larger signature.+deepInject3 :: (HDifunctor (f1 :+: f2 :+: f3), f1 :<: g, f2 :<: g, f3 :<: g)+ => CxtFun (f1 :+: f2 :+: f3) g+deepInject3 = appSigFun inj3-}++injectConst :: (HDifunctor g, g :<: f) => Const g :-> Cxt h f Any a+injectConst = inject . hfmap (const undefined)++injectConst2 :: (HDifunctor f1, HDifunctor f2, HDifunctor g, f1 :<: g, f2 :<: g)+ => Const (f1 :+: f2) :-> Cxt h g Any a+injectConst2 = inject2 . hfmap (const undefined)++injectConst3 :: (HDifunctor f1, HDifunctor f2, HDifunctor f3, HDifunctor g,+ f1 :<: g, f2 :<: g, f3 :<: g)+ => Const (f1 :+: f2 :+: f3) :-> Cxt h g Any a+injectConst3 = inject3 . hfmap (const undefined)++projectConst :: (HDifunctor g, g :<: f) => NatM Maybe (Cxt h f Any a) (Const g)+projectConst = fmap (hfmap (const (K ()))) . project++{-| 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 (Term t) = inject $ hfmap injectCxt t+injectCxt (Hole x) = x+injectCxt (Place p) = Place p++{-| This function lifts the given functor to a context. -}+liftCxt :: (HDifunctor f, g :<: f) => g a b :-> Cxt Hole f a b+liftCxt g = simpCxt $ inj g++instance (Show (f a b i), Show (g a b i)) => Show ((f :+: g) a b i) where+ show (Inl v) = show v+ show (Inr v) = show v++instance (Ord (f a b i), Ord (g a b i)) => Ord ((f :+: g) a b i) where+ compare (Inl _) (Inr _) = LT+ compare (Inr _) (Inl _) = GT+ compare (Inl x) (Inl y) = compare x y+ compare (Inr x) (Inr y) = compare x y++instance (Eq (f a b i), Eq (g a b i)) => Eq ((f :+: g) a b i) where+ (Inl x) == (Inl y) = x == y+ (Inr x) == (Inr y) = x == y + _ == _ = False
+ src/Data/Comp/MultiParam/Term.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE GADTs, KindSignatures, RankNTypes, MultiParamTypeClasses,+ TypeOperators, ScopedTypeVariables, EmptyDataDecls #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.MultiParam.Term+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the central notion of /generalised parametrised terms/+-- and their generalisation to generalised parametrised contexts.+--+--------------------------------------------------------------------------------++module Data.Comp.MultiParam.Term+ (+ Cxt(..),+ Hole,+ NoHole,+ Any,+ Term,+ Trm,+ Context,+ Const,+ simpCxt,+ coerceCxt,+ toCxt,+ constTerm,+ hfmapCxt,+ hdimapMCxt+ ) where++import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)+import Data.Comp.MultiParam.Any+import Data.Comp.MultiParam.HDifunctor+import Data.Comp.MultiParam.HDitraversable+import Control.Monad +import Unsafe.Coerce++{-| 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+ Term :: f a (Cxt h f a b) i -> Cxt h f a b i+ Hole :: b i -> Cxt Hole f a b i+ Place :: 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, but must be parametric in the bound+ parameters. Parametricity is \"emulated\" using the empty functor @Any@,+ e.g. a function of type @Any :-> T[Any]@ is equivalent with+ @forall b. b :-> T[b]@, but the former avoids the impredicative typing+ extension, and works also in the cases where the codomain type is not a type+ constructor, e.g. @Any i -> (Any i,Any i)@. -}+type Context = Cxt Hole+++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. Parametricity is \"emulated\"+ using the empty functor @Any@, e.g. a function of type @Any :-> T[Any]@ is+ equivalent with @forall b. b :-> T[b]@, but the former avoids the+ impredicative typing extension, and works also in the cases where the+ codomain type is not a type constructor, e.g. @Any i -> (Any i,Any i)@. -}+type Term f = Trm f Any++{-| Convert a difunctorial value into a context. -}+simpCxt :: HDifunctor f => f a b :-> Cxt Hole f a b+{-# INLINE simpCxt #-}+simpCxt = Term . hfmap Hole++{-| Cast a \"pseudo-parametric\" context over a signature to a parametric+ context over the same signature. The usage of 'unsafeCoerce' is safe, because+ the empty functor 'Any' witnesses that all uses of the contravariant argument+ are parametric. -}+coerceCxt :: Cxt h f Any b i -> forall a. Cxt h f a b i+coerceCxt = unsafeCoerce++toCxt :: HDifunctor f => Trm f a :-> Cxt h f a b+{-# INLINE toCxt #-}+toCxt = unsafeCoerce++{-| -}+type Const f i = f Any (K ()) i++{-| 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 the+ argument type of the higher-order difunctor @f@. -}+constTerm :: HDifunctor f => Const f :-> Term f+constTerm = Term . hfmap (const undefined)++-- | 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 (Term t) = Term $ hfmap run t+ run (Place a) = Place 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 m a+ => (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 (Term t) = liftM Term $ hdimapM run t+ run (Place a) = return $ Place a+ run (Hole b) = liftM Hole (f b)
src/Data/Comp/Ops.hs view
@@ -104,8 +104,7 @@ infixr 7 :&: -{-| This data type adds a constant product to a signature. -}-+{-| This data type adds a constant product (annotation) to a signature. -} data (f :&: a) e = f e :&: a @@ -126,42 +125,41 @@ mapM f (v :&: c) = liftM (:&: c) (mapM f v) sequence (v :&: c) = liftM (:&: c) (sequence v) -{-| This class defines how to distribute a product over a sum of+{-| This class defines how to distribute an annotation over a sum of signatures. -}--class DistProd s p s' | s' -> s, s' -> p where- {-| Inject a product value over a signature. -}- injectP :: p -> s a -> s' a- {-| Project a product value from a signature. -}- projectP :: s' a -> (s a, p)+class DistAnn s p s' | s' -> s, s' -> p where+ {-| Inject an annotation over a signature. -}+ injectA :: p -> s a -> s' a+ {-| Project an annotation from a signature. -}+ projectA :: s' a -> (s a, p) -class RemoveP s s' | s -> s' where- {-| Remove products from a signature. -}- removeP :: s a -> s' a+class RemA s s' | s -> s' where+ {-| Remove annotations from a signature. -}+ remA :: s a -> s' a -instance (RemoveP s s') => RemoveP (f :&: p :+: s) (f :+: s') where- removeP (Inl (v :&: _)) = Inl v- removeP (Inr v) = Inr $ removeP v+instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where+ remA (Inl (v :&: _)) = Inl v+ remA (Inr v) = Inr $ remA v -instance RemoveP (f :&: p) f where- removeP (v :&: _) = v+instance RemA (f :&: p) f where+ remA (v :&: _) = v -instance DistProd f p (f :&: p) where+instance DistAnn f p (f :&: p) where - injectP c v = v :&: c+ injectA c v = v :&: c - projectP (v :&: p) = (v,p)+ projectA (v :&: p) = (v,p) -instance (DistProd s p s') => DistProd (f :+: s) p ((f :&: p) :+: s') where+instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where - injectP c (Inl v) = Inl (v :&: c)- injectP c (Inr v) = Inr $ injectP c v+ injectA c (Inl v) = Inl (v :&: c)+ injectA c (Inr v) = Inr $ injectA c v - projectP (Inl (v :&: p)) = (Inl v,p)- projectP (Inr v) = let (v',p) = projectP v+ projectA (Inl (v :&: p)) = (Inl v,p)+ projectA (Inr v) = let (v',p) = projectA v in (Inr v',p)
src/Data/Comp/Ordering.hs view
@@ -19,6 +19,7 @@ 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@@ -46,11 +47,10 @@ {-| 'OrdF' is propagated through sums. -}- instance (OrdF f, OrdF g) => OrdF (f :+: g) where compareF (Inl _) (Inr _) = LT compareF (Inr _) (Inl _) = GT compareF (Inl x) (Inl y) = compareF x y compareF (Inr x) (Inr y) = compareF x y -$(derive [instanceOrdF] $ [''Maybe, ''[]] ++ tupleTypes 2 10)+$(derive [makeOrdF] $ [''Maybe, ''[]] ++ tupleTypes 2 10)
+ src/Data/Comp/Param.hs view
@@ -0,0 +1,32 @@+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>, Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the infrastructure necessary to use+-- /Parametric Compositional Data Types/. Parametric Compositional Data Types +-- is an extension of Compositional Data Types with parametric+-- higher-order abstract syntax (PHOAS) for usage with binders. Examples of+-- usage are bundled with the package in the library+-- @examples\/Examples\/Param@.+--+--------------------------------------------------------------------------------+module Data.Comp.Param (+ module Data.Comp.Param.Term+ , module Data.Comp.Param.Algebra+ , module Data.Comp.Param.Difunctor+ , module Data.Comp.Param.Sum+ , module Data.Comp.Param.Annotation+ , module Data.Comp.Param.Equality+ ) where++import Data.Comp.Param.Term+import Data.Comp.Param.Algebra+import Data.Comp.Param.Difunctor+import Data.Comp.Param.Sum+import Data.Comp.Param.Annotation+import Data.Comp.Param.Equality
+ src/Data/Comp/Param/Algebra.hs view
@@ -0,0 +1,930 @@+{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeOperators,+ FlexibleContexts, CPP #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Algebra+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the notion of algebras and catamorphisms, and their+-- generalizations to e.g. monadic versions and other (co)recursion schemes.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Algebra (+ -- * Algebras & Catamorphisms+ Alg,+ free,+ cata,+ cata',+ appCxt,+ + -- * Monadic Algebras & Catamorphisms+ AlgM,+ algM,+ freeM,+ cataM,+ cataM',++ -- * Term Homomorphisms+ CxtFun,+ SigFun,+ TermHom,+ appTermHom,+ appTermHom',+ compTermHom,+ appSigFun,+ appSigFun',+ compSigFun,+ compTermHomSigFun,+ compSigFunTermHom,+ termHom,+ compAlg,+ compAlgSigFun,++ -- * Monadic Term Homomorphisms+ CxtFunM,+ SigFunM,+ TermHomM,+ SigFunMD,+ TermHomMD,+ sigFunM,+ appTermHomM,+ appTermHomM',+ termHomM,+ termHomMD,+ appSigFunM,+ appSigFunM',+ appSigFunMD,+ compTermHomM,+ compSigFunM,+ compSigFunTermHomM,+ 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++import Unsafe.Coerce (unsafeCoerce)++{-| 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 (Term t) = f (fmap run t)+ run (Hole x) = g x+ run (Place 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 = run . coerceCxt+ where run :: Trm f a -> a+ run (Term t) = f (fmap run t)+ run (Place 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 (Term t) = Term (fmap appCxt t)+appCxt (Hole x) = x+appCxt (Place p) = Place 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 m a, 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 m a, 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 (Term t) = f =<< dimapM run t+ run (Hole x) = g x+ run (Place p) = return p++{-| Construct a monadic catamorphism from the given monadic algebra. -}+cataM :: forall m f a. (Ditraversable f m a, Monad m)+ => AlgM m f a -> Term f -> m a+{-# NOINLINE [1] cataM #-}+cataM algm = run . coerceCxt+ where run :: Trm f a -> m a+ run (Term t) = algm =<< dimapM run t+ run (Place 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 m a, 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 TermHom f g = SigFun f (Context g)++{-| Apply a term homomorphism recursively to a term/context. -}+appTermHom :: forall f g. (Difunctor f, Difunctor g)+ => TermHom f g -> CxtFun f g+{-# NOINLINE [1] appTermHom #-}+appTermHom f = run where+ run :: CxtFun f g+ run (Term t) = appCxt (f (fmap run t))+ run (Hole x) = Hole x+ run (Place p) = Place p++{-| Apply a term homomorphism recursively to a term/context. -}+appTermHom' :: forall f g. (Difunctor g)+ => TermHom f g -> CxtFun f g+{-# NOINLINE [1] appTermHom' #-}+appTermHom' f = run where+ run :: CxtFun f g+ run (Term t) = appCxt (fmapCxt run (f t))+ run (Hole x) = Hole x+ run (Place p) = Place p++{-| Compose two term homomorphisms. -}+compTermHom :: (Difunctor g, Difunctor h)+ => TermHom g h -> TermHom f g -> TermHom f h+compTermHom f g = appTermHom f . g+++{-| Compose an algebra with a term homomorphism to get a new algebra. -}+compAlg :: (Difunctor f, Difunctor g) => Alg g a -> TermHom 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 (Term t) = Term $ f $ fmap run t+ run (Place x) = Place x+ run (Hole x) = Hole x+-- implementation via term homomorphisms+-- appSigFun f = appTermHom $ termHom 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 (Term t) = Term $ fmap run $ f t+ run (Place x) = Place 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. -}+compTermHomSigFun :: TermHom g h -> SigFun f g -> TermHom f h+compTermHomSigFun f g = f . g++{-| This function composes a term homomorphism and a signature function. -}+compSigFunTermHom :: (Difunctor g) => SigFun g h -> TermHom f g -> TermHom f h+compSigFunTermHom f g = appSigFun f . g+++{-| Lifts the given signature function to the canonical term homomorphism. -}+termHom :: Difunctor g => SigFun f g -> TermHom f g+termHom 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 context function. -}+type CxtFunM' m f g = forall h b. Cxt h f Any b -> m (Cxt h g Any b)++coerceCxtFunM :: CxtFunM' m f g -> CxtFunM m f g+coerceCxtFunM = unsafeCoerce++{-| This type represents a monadic signature function. It is similar to+ 'SigFunMD 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 TermHomM m f g = SigFunM m f (Context g)++{-| This type represents a monadic term homomorphism. It is similar to+ 'TermHomMD but has monadic values also in the domain. -}+type TermHomMD 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. -}+termHomM :: (Difunctor g, Monad m) => SigFunM m f g -> TermHomM m f g+termHomM f = liftM simpCxt . f++-- | Apply a monadic term homomorphism recursively to a+-- term/context. The monad is sequenced bottom-up.+appTermHomM :: forall f g m. (Ditraversable f m Any, Difunctor g)+ => TermHomM m f g -> CxtFunM m f g+{-# NOINLINE [1] appTermHomM #-}+appTermHomM f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM appCxt . f =<< dimapM run t+ run (Hole x) = return (Hole x)+ run (Place p) = return (Place p)+++-- | Apply a monadic term homomorphism recursively to a+-- term/context. The monad is sequence top-down.+appTermHomM' :: forall f g m. (Ditraversable g m Any)+ => TermHomM m f g -> CxtFunM m f g+appTermHomM' f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM appCxt . dimapMCxt run =<< f t+ run (Place p) = return (Place p)+ run (Hole x) = return (Hole x)+ ++{-| This function constructs the unique monadic homomorphism from the+ initial term algebra to the given term algebra. -}+termHomMD :: forall f g m. (Difunctor f, Difunctor g, Monad m)+ => TermHomMD m f g -> CxtFunM m f g+termHomMD f = run + where run :: CxtFunM m f g+ run (Term t) = liftM appCxt (f (fmap run t))+ run (Hole x) = return (Hole x)+ run (Place p) = return (Place p)++{-| This function applies a monadic signature function to the given context. -}+appSigFunM :: forall m f g . (Ditraversable f m Any)+ => SigFunM m f g -> CxtFunM m f g+appSigFunM f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM Term . f =<< dimapM run t+ run (Place x) = return $ Place x+ run (Hole x) = return $ Hole x+-- implementation via term homomorphisms+-- appSigFunM f = appTermHomM $ termHom' f++-- | 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 m Any)+ => SigFunM m f g -> CxtFunM m f g+appSigFunM' f = coerceCxtFunM run+ where run :: CxtFunM' m f g+ run (Term t) = liftM Term . dimapM run =<< f t+ run (Place x) = return $ Place x+ run (Hole x) = return $ Hole x+++{-| This function applies a signature function to the given context. -}+appSigFunMD :: forall f g m. (Ditraversable f m Any, Difunctor g, Monad m)+ => SigFunMD m f g -> CxtFunM m f g+appSigFunMD f = run + where run :: CxtFunM m f g+ run (Term t) = liftM Term (f (fmap run t))+ run (Hole x) = return (Hole x)+ run (Place p) = return (Place p)++{-| Compose two monadic term homomorphisms. -}+compTermHomM :: (Ditraversable g m Any, Difunctor h, Monad m)+ => TermHomM m g h -> TermHomM m f g -> TermHomM m f h+compTermHomM f g = appTermHomM f <=< g++{-| Compose two monadic term homomorphisms. -}+compTermHomM' :: (Ditraversable h m Any, Monad m)+ => TermHomM m g h -> TermHomM m f g -> TermHomM m f h+compTermHomM' f g = appTermHomM' f <=< g++{-| Compose two monadic term homomorphisms. -}+compTermHomM_ :: (Difunctor h, Difunctor g, Monad m)+ => TermHom g h -> TermHomM m f g -> TermHomM m f h+compTermHomM_ f g = liftM (appTermHom f) . g+++{-| Compose two monadic term homomorphisms. -}+compTermHomSigFunM :: (Monad m) => TermHomM m g h -> SigFunM m f g -> TermHomM m f h+compTermHomSigFunM f g = f <=< g++{-| Compose two monadic term homomorphisms. -}+compSigFunTermHomM :: (Ditraversable g m Any) => SigFunM m g h -> TermHomM m f g -> TermHomM m f h+compSigFunTermHomM f g = appSigFunM f <=< g++{-| Compose two monadic term homomorphisms. -}+compSigFunTermHomM' :: (Ditraversable h m Any) => SigFunM m g h -> TermHomM m f g -> TermHomM m f h+compSigFunTermHomM' f g = appSigFunM' f <=< g++{-| Compose a monadic algebra with a monadic term homomorphism to get a new+ monadic algebra. -}+compAlgM :: (Ditraversable g m a, Monad m)+ => AlgM m g a -> TermHomM 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 m a, Monad m) => AlgM m g a+ -> TermHom 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 :: forall a f. Difunctor f => Coalg f a -> a -> Term f+ana f x = run (x,[])+ where run (a,bs) = case f a bs of+ Left p -> Place p+ Right t -> Term $ fmap 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 m Any, Monad m)+ => CoalgM m f a -> a -> m (Term f)+anaM f x = run (x,[])+ where run (a,bs) = do c <- f a bs+ case c of+ Left p -> return $ Place p+ Right t -> liftM Term $ 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 = run . coerceCxt+ where run :: Trm f a -> a+ run (Term t) = f $ fmap (\x -> (x, run x)) t+ run (Place 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 m a, Monad m)+ => RAlgM m f a -> Term f -> m a+paraM f = run . coerceCxt+ where run :: Trm f a -> m a+ run (Term t) = f =<< dimapM (\x -> run x >>= \y -> return (x, y)) t+ run (Place 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 :: forall a f. (Difunctor f) => RCoalg f a -> a -> Term f+apo coa x = run (x,[])+ where run :: (a,[(a,b)]) -> Trm f b+ run (a,bs) = case coa a bs of+ Left x -> Place x+ Right t -> Term $ fmap 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 m Any, Monad m) =>+ RCoalgM m f a -> a -> m (Term f)+apoM coa x = run (x,[]) + where run :: (a,[(a,Any)]) -> m (Term f)+ run (a,bs) = do+ res <- coa a bs+ case res of+ Left x -> return $ Place x+ Right t -> liftM Term $ dimapM run' t+ run' :: Either (Term f) (a,[(a,Any)]) -> m (Term f)+ 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 (Term v) = snd $ projectA v+projectTip (Place 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 = Term $ injectA (alg v') v'+ where v' = dimap Place 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 m a, Monad m, DistAnn f a f')+ => CVAlgM m f a f' -> Term f -> m a+histoM alg = liftM projectTip . run . coerceCxt+ where run (Term t) = do t' <- dimapM run t+ r <- alg t'+ return $ Term $ injectA r t'+ run (Place p) = return $ Place 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 :: forall f a. Difunctor f => CVCoalg f a -> a -> Term f+futu coa x = run (x,[])+ where run (a,bs) = case coa a bs of+ Left p -> Place p+ Right t -> Term $ fmap run' t+ run' (Term t) = Term $ fmap run' t+ run' (Hole x) = run x+ run' (Place p) = Place 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 m Any, Monad m) =>+ CVCoalgM m f a -> a -> m (Term f)+futuM coa x = run (x,[])+ where run (a,bs) = do c <- coa a bs+ case c of + Left p -> return $ Place p+ Right t -> liftM Term $ dimapM run' t+ run' (Term t) = liftM Term $ dimapM run' t+ run' (Hole x) = run x+ run' (Place p) = return $ Place 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' :: forall f a. Difunctor f => CVCoalg' f a -> a -> Term f+futu' coa x = run (x,[])+ where run (a,bs) = run' $ coa a bs+ run' (Term t) = Term $ fmap run' t+ run' (Hole x) = run x+ run' (Place p) = Place p++-------------------------------------------+-- functions only used for rewrite rules --+-------------------------------------------++appAlgTermHom :: forall f g d . (Difunctor g) => Alg g d -> TermHom f g -> Term f -> d+{-# NOINLINE [1] appAlgTermHom #-}+appAlgTermHom alg hom = run . coerceCxt where+ run :: Trm f d -> d+ run (Term t) = run' $ hom t+ run (Place a) = a+ run' :: Context g d (Trm f d) -> d+ run' (Term t) = alg $ fmap run' t+ run' (Place a) = a+ run' (Hole x) = run x+++-- | This function applies a signature function after a term homomorphism.+appSigFunTermHom :: forall f g h. (Difunctor g)+ => SigFun g h -> TermHom f g -> CxtFun f h+{-# NOINLINE [1] appSigFunTermHom #-}+appSigFunTermHom f g = run where+ run :: CxtFun f h+ run (Term t) = run' $ g t+ run (Place a) = Place a+ run (Hole h) = Hole h+ run' :: Context g a (Cxt h' f a b) -> Cxt h' h a b+ run' (Term t) = Term $ f $ fmap run' t+ run' (Place a) = Place a+ run' (Hole h) = run h++appAlgTermHomM :: forall m g f d . (Monad m, Ditraversable g m d)+ => AlgM m g d -> TermHomM m f g -> Term f -> m d+appAlgTermHomM alg hom = run . coerceCxt where + run :: Trm f d -> m d+ run (Term t) = run' =<< hom t+ run (Place a) = return a+ run' :: Context g d (Trm f d) -> m d+ run' (Term t) = alg =<< dimapM run' t+ run' (Place a) = return a+ run' (Hole x) = run x++++appTermHomTermHomM :: forall m f g h . (Ditraversable g m Any, Difunctor h)+ => TermHomM m g h -> TermHomM m f g -> CxtFunM m f h+appTermHomTermHomM f g = coerceCxtFunM run where+ run :: CxtFunM' m f h+ run (Term t) = run' =<< g t+ run (Place a) = return $ Place a+ run (Hole h) = return $ Hole h+ run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b)+ run' (Term t) = liftM appCxt $ f =<< dimapM run' t+ run' (Place a) = return $ Place a+ run' (Hole h) = run h++appSigFunTermHomM :: forall m f g h . (Ditraversable g m Any)+ => SigFunM m g h -> TermHomM m f g -> CxtFunM m f h+appSigFunTermHomM f g = coerceCxtFunM run where+ run :: CxtFunM' m f h+ run (Term t) = run' =<< g t+ run (Place a) = return $ Place a+ run (Hole h) = return $ Hole h+ run' :: Context g Any (Cxt h' f Any b) -> m (Cxt h' h Any b)+ run' (Term t) = liftM Term $ f =<< dimapM run' t+ run' (Place a) = return $ Place a+ run' (Hole h) = run h+++-------------------+-- rewrite rules --+-------------------++#ifndef NO_RULES+{-# RULES+ "cata/appTermHom" forall (a :: Alg g d) (h :: TermHom f g) x.+ cata a (appTermHom h x) = cata (compAlg a h) x;++ "cata/appTermHom'" forall (a :: Alg g d) (h :: TermHom f g) x.+ cata a (appTermHom' h x) = appAlgTermHom 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) = appAlgTermHom a (termHom h) x;++ "cata/appSigFunTermHom" forall (f :: Alg f3 d) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ cata f (appSigFunTermHom g h x) = appAlgTermHom (compAlgSigFun f g) h x;++ "appAlgTermHom/appTermHom" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appTermHom f x) = cata (compAlg a (compTermHom h f)) x;++ "appAlgTermHom/appTermHom'" forall (a :: Alg h d) (f :: TermHom f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appTermHom' f x) = appAlgTermHom a (compTermHom h f) x;++ "appAlgTermHom/appSigFun" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appSigFun f x) = cata (compAlg a (compTermHomSigFun h f)) x;++ "appAlgTermHom/appSigFun'" forall (a :: Alg h d) (f :: SigFun f g) (h :: TermHom g h) x.+ appAlgTermHom a h (appSigFun' f x) = appAlgTermHom a (compTermHomSigFun h f) x;++ "appAlgTermHom/appSigFunTermHom" forall (a :: Alg i d) (f :: TermHom f g) (g :: SigFun g h)+ (h :: TermHom h i) x.+ appAlgTermHom a h (appSigFunTermHom g f x)+ = appAlgTermHom a (compTermHom (compTermHomSigFun h g) f) x;++ "appTermHom/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom a (appTermHom h x) = appTermHom (compTermHom a h) x;++ "appTermHom'/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom' a (appTermHom' h x) = appTermHom' (compTermHom a h) x;++ "appTermHom'/appTermHom" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom' a (appTermHom h x) = appTermHom (compTermHom a h) x;++ "appTermHom/appTermHom'" forall (a :: TermHom g h) (h :: TermHom f g) x.+ appTermHom a (appTermHom' h x) = appTermHom' (compTermHom 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) = appSigFunTermHom f (termHom g) x;++ "appSigFun'/appSigFun" forall (f :: SigFun g h) (g :: SigFun f g) x.+ appSigFun' f (appSigFun g x) = appSigFun (compSigFun f g) x;++ "appTermHom/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;++ "appTermHom/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom f (appSigFun' g x) = appTermHom' (compTermHomSigFun f g) x;++ "appTermHom'/appSigFun'" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom' f (appSigFun' g x) = appTermHom' (compTermHomSigFun f g) x;++ "appTermHom'/appSigFun" forall (f :: TermHom g h) (g :: SigFun f g) x.+ appTermHom' f (appSigFun g x) = appTermHom (compTermHomSigFun f g) x;+ + "appSigFun/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun f (appTermHom g x) = appSigFunTermHom f g x;++ "appSigFun'/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun' f (appTermHom' g x) = appTermHom' (compSigFunTermHom f g) x;++ "appSigFun/appTermHom'" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun f (appTermHom' g x) = appSigFunTermHom f g x;++ "appSigFun'/appTermHom" forall (f :: SigFun g h) (g :: TermHom f g) x.+ appSigFun' f (appTermHom g x) = appTermHom (compSigFunTermHom f g) x;+ + "appSigFunTermHom/appSigFun" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: SigFun f1 f2) x.+ appSigFunTermHom f g (appSigFun h x)+ = appSigFunTermHom f (compTermHomSigFun g h) x;++ "appSigFunTermHom/appSigFun'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: SigFun f1 f2) x.+ appSigFunTermHom f g (appSigFun' h x)+ = appSigFunTermHom f (compTermHomSigFun g h) x;++ "appSigFunTermHom/appTermHom" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFunTermHom f g (appTermHom h x)+ = appSigFunTermHom f (compTermHom g h) x;++ "appSigFunTermHom/appTermHom'" forall (f :: SigFun f3 f4) (g :: TermHom f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFunTermHom f g (appTermHom' h x)+ = appSigFunTermHom f (compTermHom g h) x;++ "appSigFun/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFun f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;++ "appSigFun'/appSigFunTermHom" forall (f :: SigFun f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appSigFun' f (appSigFunTermHom g h x) = appSigFunTermHom (compSigFun f g) h x;++ "appTermHom/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appTermHom f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;++ "appTermHom'/appSigFunTermHom" forall (f :: TermHom f3 f4) (g :: SigFun f2 f3)+ (h :: TermHom f1 f2) x.+ appTermHom' f (appSigFunTermHom g h x) = appTermHom' (compTermHom (compTermHomSigFun f g) h) x;++ "appSigFunTermHom/appSigFunTermHom" forall (f1 :: SigFun f4 f5) (f2 :: TermHom f3 f4)+ (f3 :: SigFun f2 f3) (f4 :: TermHom f1 f2) x.+ appSigFunTermHom f1 f2 (appSigFunTermHom f3 f4 x)+ = appSigFunTermHom f1 (compTermHom (compTermHomSigFun f2 f3) f4) x;+ #-}++{-# RULES + "cataM/appTermHomM" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= cataM a = appAlgTermHomM a h x;++ "cataM/appTermHomM'" forall (a :: AlgM Maybe g d) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= cataM a = appAlgTermHomM a h x;++ "cataM/appSigFunM" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.+ appSigFunM h x >>= cataM a = appAlgTermHomM a (termHomM h) x;++ "cataM/appSigFunM'" forall (a :: AlgM Maybe g d) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= cataM a = appAlgTermHomM a (termHomM h) x;++ "cataM/appTermHom" forall (a :: AlgM m g d) (h :: TermHom f g) x.+ cataM a (appTermHom h x) = appAlgTermHomM a (sigFunM h) x;++ "cataM/appTermHom'" forall (a :: AlgM m g d) (h :: TermHom f g) x.+ cataM a (appTermHom' h x) = appAlgTermHomM a (sigFunM h) x;++ "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.+ cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;++ "cataM/appSigFun'" forall (a :: AlgM m g d) (h :: SigFun f g) x.+ cataM a (appSigFun' h x) = appAlgTermHomM a (sigFunM $ termHom h) x;++ "cataM/appSigFun" forall (a :: AlgM m g d) (h :: SigFun f g) x.+ cataM a (appSigFun h x) = appAlgTermHomM a (sigFunM $ termHom h) x;++ "cataM/appSigFunTermHom" forall (a :: AlgM m h d) (g :: SigFun g h) (f :: TermHom f g) x.+ cataM a (appSigFunTermHom g f x) = appAlgTermHomM a (sigFunM $ compSigFunTermHom g f) x;++ "appTermHomM/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appTermHomM a = appTermHomM (compTermHomM a h) x;++ "appTermHomM/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM h x >>= appTermHomM a = appTermHomM (compTermHomSigFunM a h) x;++ "appTermHomM/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appTermHomM a = appTermHomTermHomM a h x;++ "appTermHomM/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= appTermHomM a = appTermHomTermHomM a (termHomM h) x;++ "appTermHomM'/appTermHomM" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;++ "appTermHomM'/appSigFunM" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;++ "appTermHomM'/appTermHomM'" forall (a :: TermHomM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appTermHomM' a = appTermHomM' (compTermHomM' a h) x;++ "appTermHomM'/appSigFunM'" forall (a :: TermHomM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= appTermHomM' a = appTermHomM' (compTermHomSigFunM a h) x;++ "appTermHomM/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM a (appTermHom h x) = appTermHomTermHomM a (sigFunM h) x;++ "appTermHomM/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM a (appSigFun h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;++ "appTermHomM'/appTermHom" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM' a (appTermHom h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;++ "appTermHomM'/appSigFun" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM' a (appSigFun h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;++ "appTermHomM/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM a (appTermHom' h x) = appTermHomTermHomM a (sigFunM h) x;++ "appTermHomM/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM a (appSigFun' h x) = appTermHomTermHomM a (sigFunM $ termHom h) x;++ "appTermHomM'/appTermHom'" forall (a :: TermHomM m g h) (h :: TermHom f g) x.+ appTermHomM' a (appTermHom' h x) = appTermHomM' (compTermHomM' a (sigFunM h)) x;++ "appTermHomM'/appSigFun'" forall (a :: TermHomM m g h) (h :: SigFun f g) x.+ appTermHomM' a (appSigFun' h x) = appTermHomM' (compTermHomSigFunM a (sigFunM h)) x;++ "appSigFunM/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appSigFunM a = appSigFunTermHomM 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/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appSigFunM a = appSigFunTermHomM a h x;++ "appSigFunM/appSigFunM'" forall (a :: SigFunM Maybe g h) (h :: SigFunM Maybe f g) x.+ appSigFunM' h x >>= appSigFunM a = appSigFunTermHomM a (termHomM h) x;++ "appSigFunM'/appTermHomM" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' 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'/appTermHomM'" forall (a :: SigFunM Maybe g h) (h :: TermHomM Maybe f g) x.+ appTermHomM' h x >>= appSigFunM' a = appTermHomM' (compSigFunTermHomM' 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/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM a (appTermHom h x) = appSigFunTermHomM a (sigFunM h) x;++ "appSigFunM/appSigFun" forall (a :: SigFunM m g h) (h :: SigFun f g) x.+ appSigFunM a (appSigFun h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;++ "appSigFunM'/appTermHom" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM' a (appTermHom h x) = appTermHomM' (compSigFunTermHomM' 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/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM a (appTermHom' h x) = appSigFunTermHomM a (sigFunM h) x;++ "appSigFunM/appSigFun'" forall (a :: SigFunM m g h) (h :: SigFun f g) x.+ appSigFunM a (appSigFun' h x) = appSigFunTermHomM a (sigFunM $ termHom h) x;++ "appSigFunM'/appTermHom'" forall (a :: SigFunM m g h) (h :: TermHom f g) x.+ appSigFunM' a (appTermHom' h x) = appTermHomM' (compSigFunTermHomM' 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;+++ "appTermHom/appTermHomM" forall (a :: TermHom g h) (h :: TermHomM m f g) x.+ appTermHomM h x >>= (return . appTermHom a) = appTermHomM (compTermHomM_ a h) x;+ #-}+#endif
+ src/Data/Comp/Param/Annotation.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,+ UndecidableInstances, RankNTypes, GADTs, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Annotation+-- Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines annotations on signatures.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Annotation+ (+ (:&:) (..),+ (:*:) (..),+ DistAnn (..),+ RemA (..),+ liftA,+ liftA',+ stripA,+ propAnn,+ propAnnM,+ ann,+ project'+ ) where++import Data.Comp.Param.Difunctor+import Data.Comp.Param.Term+import Data.Comp.Param.Sum+import Data.Comp.Param.Ops+import Data.Comp.Param.Algebra++import Control.Monad++{-| Transform a function with a domain constructed from a functor to a function+ with a domain constructed with the same functor, but with an additional+ annotation. -}+liftA :: (RemA s s') => (s' a b -> t) -> s a b -> t+liftA f v = f (remA v)++{-| Transform a function with a domain constructed from a functor to a function+ with a domain constructed with the same functor, but with an additional+ annotation. -}+liftA' :: (DistAnn s' p s, Difunctor s')+ => (s' a b -> Cxt h s' c d) -> s a b -> Cxt h s c d+liftA' f v = let (v',p) = projectA v+ in ann p (f v')++{-| Strip the annotations from a term over a functor with annotations. -}+stripA :: (RemA g f, Difunctor g) => CxtFun g f+stripA = appSigFun remA++{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism+ over the same signatures, but extended with annotations. -}+propAnn :: (DistAnn f p f', DistAnn g p g', Difunctor g) + => TermHom f g -> TermHom 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) + => TermHomM m f g -> TermHomM 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. -}+-- bug in type checker? below is the inferred type, however, the type checker+-- rejects it.+-- project' :: (RemA f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))+project' v = liftM remA $ project v
+ src/Data/Comp/Param/Any.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE EmptyDataDecls #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Any+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the empty data type 'Any', which is used to emulate+-- parametricity (\"poor mans parametricity\").+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Any+ (+ Any+ ) where++-- |The empty data type 'Any' is used to emulate parametricity+-- (\"poor mans parametricity\").+data Any
+ src/Data/Comp/Param/Derive.hs view
@@ -0,0 +1,48 @@+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module contains functionality for automatically deriving boilerplate+-- code using Template Haskell. Examples include instances of 'Difunctor',+-- 'Difoldable', and 'Ditraversable'.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Derive+ (+ derive,+ -- |Derive boilerplate instances for parametric signatures, i.e.+ -- signatures for parametric compositional data types.++ -- ** EqD+ module Data.Comp.Param.Derive.Equality,+ -- ** OrdD+ module Data.Comp.Param.Derive.Ordering,+ -- ** ShowD+ module Data.Comp.Param.Derive.Show,+ -- ** Difunctor+ module Data.Comp.Param.Derive.Difunctor,+ -- ** Ditraversable+ module Data.Comp.Param.Derive.Ditraversable,+ -- ** Smart Constructors+ module Data.Comp.Param.Derive.SmartConstructors,+ -- ** Smart Constructors w/ Annotations+ module Data.Comp.Param.Derive.SmartAConstructors,+ -- ** Lifting to Sums+ module Data.Comp.Param.Derive.LiftSum+ ) where++import Data.Comp.Derive.Utils (derive)+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.Derive.LiftSum
+ src/Data/Comp/Param/Derive/Difunctor.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.Functor+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @Difunctor@.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Derive.Difunctor+ (+ Difunctor,+ makeDifunctor+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Param.Difunctor+import Language.Haskell.TH++{-| Derive an instance of 'Difunctor' for a type constructor of any parametric+ kind taking at least two arguments. -}+makeDifunctor :: Name -> Q [Dec]+makeDifunctor fname = do+ -- Comments below apply to the example where name = T, args = [a,b,c], and+ -- constrs = [(X,[c]), (Y,[a,c]), (Z,[b -> c])], i.e. the data type+ -- declaration: T a b c = X c | Y a c | Z (b -> c)+ TyConI (DataD _ name args constrs _) <- abstractNewtypeQ $ reify fname+ -- coArg = c (covariant difunctor argument)+ let coArg :: Name = tyVarBndrName $ last args+ -- conArg = b (contravariant difunctor argument)+ let conArg :: Name = tyVarBndrName $ last $ init args+ -- argNames = [a]+ let argNames = map (VarT . tyVarBndrName) (init $ init args)+ -- compType = T a+ let complType = foldl AppT (ConT name) argNames+ -- classType = Difunctor (T a)+ let classType = AppT (ConT ''Difunctor) complType+ -- constrs' = [(X,[c]), (Y,[a,c]), (Z,[b -> c])]+ constrs' :: [(Name,[Type])] <- mapM normalConExp constrs+ dimapDecl <- funD 'dimap (map (dimapClause conArg coArg) constrs')+ return [InstanceD [] classType [dimapDecl]]+ where dimapClause :: Name -> Name -> (Name,[Type]) -> ClauseQ+ dimapClause conArg coArg (constr, args) = do+ fn <- newName "_f"+ gn <- newName "_g"+ varNs <- newNames (length args) "x"+ let f = varE fn+ let g = varE gn+ let fp = VarP fn+ let gp = VarP gn+ -- Pattern for the constructor+ let pat = ConP constr $ map VarP varNs+ body <- dimapArgs conArg coArg f g (zip varNs args) (conE constr)+ return $ Clause [fp, gp, pat] (NormalB body) []+ dimapArgs :: Name -> Name -> ExpQ -> ExpQ+ -> [(Name, Type)] -> ExpQ -> ExpQ+ dimapArgs _ _ _ _ [] acc =+ acc+ dimapArgs conArg coArg f g ((x,tp):tps) acc =+ dimapArgs conArg coArg f g tps+ (acc `appE` (dimapArg conArg coArg tp f g `appE` varE x))+ -- Given the name of the difunctor variables, a type, and the two+ -- arguments to dimap, return the expression that should be applied+ -- to the parameter of the given type.+ -- Example: dimapArg a b (a -> b) f g yields the expression+ -- [|\x -> g . x . f|]+ dimapArg :: Name -> Name -> Type -> ExpQ -> ExpQ -> ExpQ+ dimapArg conArg coArg tp f g+ | not (containsType tp (VarT conArg)) &&+ not (containsType tp (VarT coArg)) = [| id |]+ | otherwise =+ case tp of+ VarT a | a == conArg -> f+ | a == coArg -> g+ AppT (AppT ArrowT tp1) tp2 -> do+ xn <- newName "x"+ let ftp1 = dimapArg conArg coArg tp1 f g+ let ftp2 = dimapArg conArg coArg tp2 f g+ lamE [varP xn]+ (infixE (Just ftp2)+ [|(.)|]+ (Just $ infixE (Just $ varE xn)+ [|(.)|]+ (Just ftp1)))+ SigT tp' _ ->+ dimapArg conArg coArg tp' f g+ _ ->+ if containsType tp (VarT conArg) then+ [| dimap $f $g |]+ else+ [| fmap $g |]
+ src/Data/Comp/Param/Derive/Ditraversable.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.Ditraversable+-- Copyright : (c) 2010-2011 Patrick Bahr+-- License : BSD3+-- Maintainer : Patrick Bahr <paba@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @Ditraversable@.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Derive.Ditraversable+ (+ Ditraversable,+ makeDitraversable+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Param.Ditraversable+import Data.Traversable (mapM)+import Language.Haskell.TH+import Data.Maybe+import Control.Monad hiding (mapM)+import Prelude hiding (mapM)++iter 0 _ e = e+iter n f e = iter (n-1) f (f `appE` e)++iter' n f e = run n f e+ where run 0 _ e = e+ run m f e = let f' = iter (m-1) [|fmap|] f+ in run (m-1) f (f' `appE` e)++{-| Derive an instance of 'Traversable' for a type constructor of any+ first-order kind taking at least one argument. -}+makeDitraversable :: Name -> Q [Dec]+makeDitraversable fname = do+ TyConI (DataD _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname+ monadType <- varT =<< newName "m"+ domainType <- varT =<< newName "d"+ 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, monadType,domainType]+ normConstrs <- mapM normalConExp constrs+ let hasFunTy = or $ map (checksAarg funTy) normConstrs+ context = [ClassP ''Monad [monadType]] +++ if hasFunTy+ then [ClassP ''Ditraversable [ArrowT,monadType,domainType] ]+ else []+ constrs' <- mapM (mkPatAndVars . isFarg fArg funTy) normConstrs+ mapMDecl <- funD 'dimapM (map mapMClause constrs')+ sequenceDecl <- funD 'disequence (map sequenceClause constrs')+ return [InstanceD context classType [mapMDecl,sequenceDecl]]+ where isFarg fArg funTy (constr, args) =+ (constr, map (\t -> (t `containsType'` fArg, t `containsType'` funTy)) args)+ checksAarg aArg (_,args) = any (`containsType` aArg) args+ filterVar _ _ nonFarg ([],[]) x = nonFarg x+ filterVar farg _ _ ([depth],[]) x = farg depth x+ filterVar _ aarg _ ([_],[depth]) x = aarg depth x+ filterVar _ _ _ _ _ = error "functor variable occurring twice in argument type"+ filterVars args varNs farg aarg nonFarg = zipWith (filterVar farg aarg nonFarg) args varNs+ mkCPat constr varNs = ConP constr $ map mkPat varNs+ mkPat = VarP+ mkPatAndVars (constr, args) =+ do varNs <- newNames (length args) "x"+ return (conE constr, mkCPat constr varNs,+ any (not . null . fst) args || any (not . null . snd) args, map varE varNs,+ catMaybes $ filterVars args varNs (\x y -> Just (False,x,y)) (\x y -> Just (True, x, y)) (const Nothing))++ -- Note: the monadic versions are not defined+ -- applicatively, as this results in a considerable+ -- performance penalty (by factor 2)!+ mapMClause (con, pat,hasFargs,allVars, fvars) =+ do fn <- newName "f"+ let f = varE fn+ fp = if hasFargs then VarP fn else WildP+ conAp = foldl appE con allVars+ addDi False _ x = x+ addDi True d x = [|dimapM $(f)|]+ conBind (fun,d,x) y = [| $(iter d [|mapM|] (addDi fun d f)) $(varE x) >>= $(lamE [varP x] y)|]+ body <- foldr conBind [|return $conAp|] fvars+ return $ Clause [fp, pat] (NormalB body) []+ sequenceClause (con, pat,hasFargs,allVars, fvars) =+ do let conAp = foldl appE con allVars+ varE' False _ x = varE x+ varE' True d x = appE (iter d [|fmap|] [|disequence|]) (varE x)+ conBind (fun,d, x) y = [| $(iter' d [|sequence|] (varE' fun d x)) >>= $(lamE [varP x] y)|]+ body <- foldr conBind [|return $conAp|] fvars+ return $ Clause [pat] (NormalB body) []
+ src/Data/Comp/Param/Derive/Equality.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,+ ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.Equality+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @EqD@.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.Derive.Equality+ (+ EqD(..),+ makeEqD+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Param.FreshM+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)+ return [InstanceD [] 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 ->+ [| do {v <- genVar;+ peq ($(varE x) v) ($(varE y) v)} |]+ SigT tp' _ ->+ eqDB conArg coArg (x, y, tp')+ _ ->+ if containsType tp (VarT conArg) then+ [| eqD $(varE x) $(varE y) |]+ else+ [| peq $(varE x) $(varE y) |]
+ src/Data/Comp/Param/Derive/Injections.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.Injections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature injections.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Derive.Injections+ (+ injn,+ injectn,+ deepInjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Param.Difunctor+import Data.Comp.Param.Term+import Data.Comp.Param.Algebra (CxtFun, appSigFun)+import Data.Comp.Param.Ops ((:+:)(..), (:<:)(..))++injn :: Int -> Q [Dec]+injn n = do+ let i = mkName $ "inj" ++ show n+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let bvar = mkName "b"+ let xvar = mkName "x"+ let d = [funD i [clause [varP xvar] (normalB $ genDecl xvar n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar bvar) : d+ where genSig fvars gvar avar bvar = do+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = arrowT `appT` (tp `appT` varT avar `appT` varT bvar)+ `appT` (varT gvar `appT` varT avar `appT`+ varT bvar)+ forallT (map PlainTV $ gvar : avar : bvar : fvars)+ (sequence cxt) tp'+ genDecl x n = [| case $(varE x) of+ Inl x -> $(varE $ mkName $ "inj") x+ Inr x -> $(varE $ mkName $ "inj" +++ if n > 2 then show (n - 1) else "") x |]+injectn :: Int -> Q [Dec]+injectn n = do+ let i = mkName ("inject" ++ show n)+ let fvars = map (\n -> mkName $ 'f' : show n) [1..n]+ let gvar = mkName "g"+ let avar = mkName "a"+ let bvar = mkName "b"+ let d = [funD i [clause [] (normalB $ genDecl n) []]]+ sequence $ (sigD i $ genSig fvars gvar avar bvar) : d+ where genSig fvars gvar avar bvar = do+ let hvar = mkName "h"+ let cxt = map (\f -> classP ''(:<:) [varT f, varT gvar]) fvars+ let tp = foldl1 (\a f -> conT ''(:+:) `appT` f `appT` a)+ (map varT fvars)+ let tp' = conT ''Cxt `appT` varT hvar `appT` varT gvar+ `appT` varT avar `appT` varT bvar+ let tp'' = arrowT `appT` (tp `appT` varT avar `appT` tp') `appT` tp'+ forallT (map PlainTV $ hvar : gvar : avar : bvar : fvars)+ (sequence cxt) tp''+ genDecl n = [| 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 ''Difunctor [tp]+ let tp' = conT ''CxtFun `appT` tp `appT` varT gvar+ forallT (map PlainTV $ gvar : fvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFun $(varE $ mkName $ "inj" ++ show n) |]
+ src/Data/Comp/Param/Derive/LiftSum.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.LiftSum+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Lift a class declaration for difunctors to sums of difunctors.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Derive.LiftSum+ (+ liftSum,+ caseD+ ) where++import Language.Haskell.TH hiding (Cxt)+import Data.Comp.Derive.Utils+import Data.Comp.Param.Sum+import Data.Comp.Param.Ops ((:+:)(..))++{-| 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 fname = do+ ClassI (ClassD _ name targs _ decs) _ <- abstractNewtypeQ $ reify fname+ let targs' = map tyVarBndrName $ tail targs+ let f = mkName "f"+ let g = mkName "g"+ let cxt = [ClassP name (map VarT $ f : targs'),+ ClassP name (map VarT $ g : targs')]+ let tp = ConT name `AppT` ((ConT ''(:+:) `AppT` VarT f) `AppT` VarT g)+ let complType = foldl (\a x -> a `AppT` VarT x) tp targs'+ decs' <- sequence $ concatMap decl decs+ return [InstanceD cxt complType decs']+ where decl :: Dec -> [DecQ]+ decl (SigD f _) = [funD f [clause f]]+ decl _ = []+ clause :: Name -> ClauseQ+ clause f = do x <- newName "x"+ b <- normalB [|caseD $(varE f) $(varE f) $(varE x)|]+ return $ Clause [VarP x] 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
+ src/Data/Comp/Param/Derive/Ordering.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,+ ScopedTypeVariables #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.Ordering+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @OrdD@.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.Derive.Ordering+ (+ OrdD(..),+ makeOrdD+ ) where++import Data.Comp.Param.FreshM+import Data.Comp.Param.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 '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')+ return [InstanceD [] 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 ->+ [| do {v <- genVar;+ pcompare ($(varE x) v) ($(varE y) v)} |]+ SigT tp' _ ->+ eqDB conArg coArg (x, y, tp')+ _ ->+ if containsType tp (VarT conArg) then+ [| compareD $(varE x) $(varE y) |]+ else+ [| pcompare $(varE x) $(varE y) |]+ genLtClause (c, _) (d, _) =+ clause [recP c [], recP d []] (normalB [| return LT |]) []+ genGtClause (c, _) (d, _) =+ clause [recP c [], recP d []] (normalB [| return GT |]) []
+ src/Data/Comp/Param/Derive/Projections.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.Projections+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Derive functions for signature projections.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Derive.Projections+ (+ projn,+ projectn,+ deepProjectn+ ) where++import Language.Haskell.TH hiding (Cxt)+import Control.Monad (liftM)+import Data.Comp.Param.Ditraversable (Ditraversable)+import Data.Comp.Param.Term+import Data.Comp.Param.Algebra (CxtFunM, appSigFunM')+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+ Place _ -> 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 ''Ditraversable [tp, conT ''Maybe, conT ''Any]+ let tp' = conT ''CxtFunM `appT` conT ''Maybe+ `appT` varT fvar `appT` tp+ forallT (map PlainTV $ fvar : gvars) (sequence $ cxt' : cxt) tp'+ genDecl n = [| appSigFunM' $(varE $ mkName $ "proj" ++ show n) |]
+ src/Data/Comp/Param/Derive/Show.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, IncoherentInstances,+ ScopedTypeVariables, UndecidableInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.Show+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive instances of @ShowD@.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.Derive.Show+ (+ PShow(..),+ ShowD(..),+ makeShowD+ ) where++import Data.Comp.Derive.Utils+import Data.Comp.Param.FreshM+import Control.Monad+import Language.Haskell.TH hiding (Cxt, match)++-- |Printing of parametric values.+class PShow a where+ pshow :: a -> FreshM String++{-| Signature printing. An instance @ShowD f@ gives rise to an instance+ @Show (Term f)@. -}+class ShowD f where+ showD :: PShow a => f Var a -> FreshM String++{-| 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')+ return [InstanceD [] 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 -> [| pshow $(varE x) |]+ AppT (AppT ArrowT (VarT a)) _+ | a == conArg ->+ [| do {v <- genVar;+ body <- pshow $ $(varE x) v;+ return $ "\\" ++ show v ++ " -> " ++ body} |]+ SigT tp' _ ->+ showDB conArg coArg (x, tp')+ _ ->+ if containsType tp (VarT conArg) then+ [| showD $(varE x) |]+ else+ [| pshow $(varE x) |]
+ src/Data/Comp/Param/Derive/SmartAConstructors.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.SmartAConstructors+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive smart constructors with annotations.+--+--------------------------------------------------------------------------------++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 Control.Monad++{-| Derive smart constructors with products for a type constructor of any+ parametric kind taking at least two arguments. The smart constructors are+ similar to the ordinary constructors, but an 'injectA' 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|] $ foldl appE (conE name) vars+ function = [funD sname [clause pats (normalB [|Term $val|]) []]]+ sequence function
+ src/Data/Comp/Param/Derive/SmartConstructors.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Derive.SmartConstructors+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- Automatically derive smart constructors for parametric types.+--+--------------------------------------------------------------------------------++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 Control.Monad++{-| Derive smart constructors for a type constructor of any parametric 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+ 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 $val|]) []]]+ sequence $ sig ++ function+ genSig targs tname sname 0 = (:[]) $ do+ hvar <- newName "h"+ fvar <- newName "f"+ avar <- newName "a"+ bvar <- newName "b"+ let targs' = init $ init targs+ vars = hvar:fvar:avar:bvar:targs'+ h = varT hvar+ f = varT fvar+ a = varT avar+ b = varT bvar+ ftype = foldl appT (conT tname) (map varT targs')+ constr = classP ''(:<:) [ftype, f]+ typ = foldl appT (conT ''Cxt) [h, f, a, b]+ typeSig = forallT (map PlainTV vars) (sequence [constr]) typ+ sigD sname typeSig+ genSig _ _ _ _ = []
+ src/Data/Comp/Param/Desugar.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FlexibleInstances,+ UndecidableInstances, OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Desugar+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This modules defines the 'Desugar' type class for desugaring of terms.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Desugar where++import Data.Comp.Param+import Data.Comp.Param.Derive++-- |The desugaring term homomorphism.+class (Difunctor f, Difunctor g) => Desugar f g where+ desugHom :: TermHom f g+ desugHom = desugHom' . fmap Hole+ desugHom' :: f a (Cxt h g a b) -> Cxt h g a b+ desugHom' x = appCxt (desugHom x)++$(derive [liftSum] [''Desugar])++-- |Desugar a term.+desugar :: Desugar f g => Term f -> Term g+{-# INLINE desugar #-}+desugar = appTermHom desugHom++-- |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 = appTermHom (propAnn desugHom)++-- |Default desugaring instance.+instance (Difunctor f, Difunctor g, f :<: g) => Desugar f g where+ desugHom = simpCxt . inj
+ src/Data/Comp/Param/Difunctor.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Difunctor+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines difunctors (Meijer, Hutton, FPCA '95), i.e. binary type+-- constructors that are contravariant in the first argument and covariant in+-- the second argument.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Difunctor+ (+ 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++instance Difunctor f => Functor (f a) where+ fmap = dimap id
+ src/Data/Comp/Param/Ditraversable.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses,+ FlexibleContexts, OverlappingInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Ditraversable+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines traversable difunctors.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Ditraversable+ (+ Ditraversable(..)+ ) where++import Prelude hiding (mapM, sequence, foldr)+import Data.Maybe (fromJust)+import Data.Comp.Param.Any+import Data.Comp.Param.Difunctor+import Test.QuickCheck.Gen+import Data.Functor.Identity+import Control.Monad.Reader hiding (mapM, sequence)+import Control.Monad.Error hiding (mapM, sequence)+import Control.Monad.State hiding (mapM, sequence)+import Control.Monad.List hiding (mapM, sequence)+import Control.Monad.RWS hiding (Any, mapM, sequence)+import Control.Monad.Writer hiding (Any, mapM, sequence)++{-| Difunctors representing data structures that can be traversed from left to+ right. -}+class (Difunctor f, Monad m) => Ditraversable f m a where+ dimapM :: (b -> m c) -> f a b -> m (f a c)+ dimapM f = disequence . fmap f++ disequence :: f a (m b) -> m (f a b)+ disequence = dimapM id+++instance Ditraversable (->) Gen a where+ dimapM f s = MkGen run+ where run stdGen seed a = unGen (f (s a)) stdGen seed+ disequence s = MkGen run+ where run stdGen seed a = unGen (s a) stdGen seed++instance Ditraversable (->) Identity a where+ dimapM f s = Identity run+ where run a = runIdentity (f (s a))+ disequence s = Identity run+ where run a = runIdentity (s a)++instance Ditraversable (->) m a => Ditraversable (->) (ReaderT r m) a where+ dimapM f s = ReaderT (disequence . run)+ where run r a = runReaderT (f (s a)) r+ disequence s = ReaderT (disequence . run)+ where run r a = runReaderT (s a) r+++{-| Functions of the type @Any -> Maybe a@ can be turned into functions of+ type @Maybe (Any -> a)@. The empty type @Any@ ensures that the function+ is parametric in the input, and hence the @Maybe@ monad can be pulled out. -}+instance Ditraversable (->) Maybe Any where+ dimapM f g = disequence (f .g)+ disequence f = do _ <- f undefined+ return $ \x -> fromJust $ f x+++instance Ditraversable (->) (Either e) Any where+ dimapM f g = disequence (f . g)+ disequence h = case h undefined of+ Left e -> Left e+ Right _ -> Right $ fromRight . h+ where fromRight (Right x) = x+ fromRight (Left _) = error "fromRight: expected Right"++instance (Error e, Ditraversable (->) m Any) => Ditraversable (->) (ErrorT e m) Any where+ dimapM f g = disequence (f . g)+ disequence h = ErrorT $+ do r <- runErrorT (h undefined) + case r of+ Left e -> return $ Left e+ Right _ -> liftM Right $ disequence (liftM fromRight . runErrorT . h) + where fromRight (Right x) = x+ fromRight (Left _) = error "fromRight: expected Right"++instance (Ditraversable (->) m Any) => Ditraversable (->) (StateT s m) Any where+ dimapM f g = disequence (f . g)+ disequence h = StateT trans+ where trans s = + do (_,s') <- runStateT (h undefined) s+ fun <- disequence (liftM fst . (`runStateT` s) . h)+ return (fun,s')++instance (Monoid w, Ditraversable (->) m Any) => Ditraversable (->) (WriterT w m) Any where+ dimapM f g = disequence (f . g)+ disequence h = WriterT trans+ where trans = + do (_,w) <- runWriterT (h undefined)+ fun <- disequence (liftM fst . runWriterT . h)+ return (fun,w)++instance Ditraversable (->) [] Any where + dimapM f g = disequence (f . g)+ disequence h = run (h undefined) 0+ where run [] _ = []+ run (_ : xs) i = let f a = h a !! i+ in f : run xs (i+1)++instance Ditraversable (->) m Any => Ditraversable (->) (ListT m) Any where + dimapM f g = disequence (f . g)+ disequence h = ListT $ (`run` 0) =<< runListT (h undefined)+ where run [] _ = return []+ run (_ : xs) i = do f <- disequence $ liftM (!! i) . runListT . h+ liftM (f :) (run xs (i+1))++instance (Monoid w, Ditraversable (->) m Any) => Ditraversable (->) (RWST r w s m) Any where+ dimapM f g = disequence (f . g)+ disequence h = RWST trans+ where trans r s = + do (_,s',w) <- runRWST (h undefined) r s+ fun <- disequence (liftM fst' . (\ m -> runRWST m r s) . h)+ return (fun,s',w)+ fst' (x,_,_) = x
+ src/Data/Comp/Param/Equality.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,+ UndecidableInstances, IncoherentInstances, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Equality+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines equality for signatures, which lifts to equality for+-- terms.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.Equality+ (+ PEq(..),+ EqD(..)+ ) where++import Data.Comp.Param.Term+import Data.Comp.Param.Sum+import Data.Comp.Param.Ops+import Data.Comp.Param.Difunctor+import Data.Comp.Param.FreshM++-- |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 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 Var a -> f Var 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 (Term e1) (Term e2) = eqD e1 e2+ eqD (Hole h1) (Hole h2) = peq h1 h2+ eqD (Place p1) (Place p2) = peq p1 p2+ eqD _ _ = return False++instance (EqD f, PEq a) => PEq (Cxt h f Var a) where+ peq = eqD++{-| Equality on terms. -}+instance (Difunctor f, EqD f) => Eq (Term f) where+ (==) x y = evalFreshM $ eqD (coerceCxt x) (coerceCxt y)
+ src/Data/Comp/Param/FreshM.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.FreshM+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines a monad for generating fresh, abstract variables, useful+-- e.g. for defining equality on terms.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.FreshM+ (+ FreshM,+ Var,+ genVar,+ evalFreshM+ ) where++import Control.Monad.State++-- |Monad for generating fresh (abstract) variables.+newtype FreshM a = FreshM (State [String] a)+ deriving Monad++-- |Abstract notion of a variable (the constructor is hidden).+data Var = Var String+ deriving Eq++instance Show Var where+ show (Var x) = x++instance Ord Var where+ compare (Var x) (Var y) = compare x y++-- |Generate a fresh variable.+genVar :: FreshM Var+genVar = FreshM $ do xs <- get+ case xs of+ (x : xs') -> do {put xs'; return $ Var x}+ _ -> fail "Unexpected empty list"++-- |Evaluate a computation that uses fresh variables.+evalFreshM :: FreshM a -> a+evalFreshM (FreshM m) = evalState m vars+ where baseVars = ['a'..'z']+ vars = map (:[]) baseVars ++ vars' 1+ vars' n = map (: show n) baseVars ++ vars' (n + 1)
+ src/Data/Comp/Param/Ops.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies,+ FlexibleInstances, UndecidableInstances, IncoherentInstances #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Ops+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module provides operators on difunctors.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Ops where++import Data.Comp.Param.Difunctor+import Data.Comp.Param.Ditraversable+import Control.Monad (liftM)+++-- Sums+infixr 6 :+:++-- |Formal sum of signatures (difunctors).+data (f :+: g) a b = Inl (f a b)+ | Inr (g a b)++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 m a, Ditraversable g m a)+ => Ditraversable (f :+: g) m a 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 m a => Ditraversable (f :&: p) m a where+ dimapM f (v :&: c) = liftM (:&: c) (dimapM f v)+ disequence (v :&: c) = liftM (:&: c) (disequence v)++{-| This class defines how to distribute an annotation over a sum of+ signatures. -}+class DistAnn s p s' | s' -> s, s' -> p where+ {-| Inject an annotation over a signature. -}+ injectA :: p -> s a b -> s' a b+ {-| Project an annotation from a signature. -}+ projectA :: s' a b -> (s a b, p)++class RemA s s' | s -> s' where+ {-| Remove annotations from a signature. -}+ remA :: s a b -> s' a b++instance (RemA s s') => RemA (f :&: p :+: s) (f :+: s') where+ remA (Inl (v :&: _)) = Inl v+ remA (Inr v) = Inr $ remA v++instance RemA (f :&: p) f where+ remA (v :&: _) = v++instance DistAnn f p (f :&: p) where+ injectA c v = v :&: c++ projectA (v :&: p) = (v,p)++instance (DistAnn s p s') => DistAnn (f :+: s) p ((f :&: p) :+: s') where+ injectA c (Inl v) = Inl (v :&: c)+ injectA c (Inr v) = Inr $ injectA c v++ projectA (Inl (v :&: p)) = (Inl v,p)+ projectA (Inr v) = let (v',p) = projectA v+ in (Inr v',p)
+ src/Data/Comp/Param/Ordering.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleInstances,+ UndecidableInstances, IncoherentInstances, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Ordering+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines ordering of signatures, which lifts to ordering of+-- terms and contexts.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.Ordering+ (+ POrd(..),+ OrdD(..)+ ) 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++-- |Ordering of parametric values.+class PEq a => POrd a where+ pcompare :: a -> a -> FreshM Ordering++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 Var a -> f Var 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 (Term e1) (Term e2) = compareD e1 e2+ compareD (Hole h1) (Hole h2) = pcompare h1 h2+ compareD (Place p1) (Place p2) = pcompare p1 p2+ compareD (Term _) _ = return LT+ compareD (Hole _) (Term _) = return GT+ compareD (Hole _) (Place _) = return LT+ compareD (Place _) _ = return GT++instance (OrdD f, POrd a) => POrd (Cxt h f Var a) where+ pcompare = compareD++{-| Ordering of terms. -}+instance (Difunctor f, OrdD f) => Ord (Term f) where+ compare x y = evalFreshM $ compareD (coerceCxt x) (coerceCxt y)
+ src/Data/Comp/Param/Show.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeOperators, FlexibleInstances, TypeSynonymInstances,+ IncoherentInstances, UndecidableInstances, TemplateHaskell, GADTs #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Show+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines showing of signatures, which lifts to showing of terms.+--+--------------------------------------------------------------------------------+module Data.Comp.Param.Show+ (+ PShow(..),+ ShowD(..)+ ) where++import Data.Comp.Param.Term+import Data.Comp.Param.Ops+import Data.Comp.Param.Derive+import Data.Comp.Param.FreshM++instance Show a => PShow a where+ pshow x = return $ show x++-- Lift ShowD to sums+$(derive [liftSum] [''ShowD])++{-| From an 'ShowD' difunctor an 'ShowD' instance of the corresponding term type+ can be derived. -}+instance ShowD f => ShowD (Cxt h f) where+ showD (Term t) = showD t+ showD (Hole h) = pshow h+ showD (Place p) = pshow p++instance (ShowD f, PShow a) => PShow (Cxt h f Var a) where+ pshow = showD++{-| Printing of terms. -}+instance (Difunctor f, ShowD f) => Show (Term f) where+ show x = evalFreshM $ showD $ coerceCxt x++instance (ShowD f, PShow p) => ShowD (f :&: p) where+ showD (x :&: p) = do sx <- showD x+ sp <- pshow p+ return $ sx ++ " :&: " ++ sp
+ src/Data/Comp/Param/Sum.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,+ FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,+ ScopedTypeVariables, TemplateHaskell #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Sum+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module provides the infrastructure to extend signatures.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Sum+ (+ (:<:),+ (:+:),++ -- * 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,++ -- * Injections and Projections for Constants+ injectConst,+ injectConst2,+ injectConst3,+ projectConst,+ 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 (Term t) = proj t+project (Hole _) = Nothing+project (Place _) = 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 Maybe Any, g :<: f) => CxtFunM Maybe f g+{-# 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 a (Cxt h f a b) -> Cxt h f a b+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/+-- instead.+deepInject :: (Difunctor 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 #-}++injectConst :: (Difunctor g, g :<: f) => Const g -> Cxt h f Any a+injectConst = inject . fmap (const undefined)++injectConst2 :: (Difunctor f1, Difunctor f2, Difunctor g, f1 :<: g, f2 :<: g)+ => Const (f1 :+: f2) -> Cxt h g Any a+injectConst2 = inject2 . fmap (const undefined)++injectConst3 :: (Difunctor f1, Difunctor f2, Difunctor f3, Difunctor g,+ f1 :<: g, f2 :<: g, f3 :<: g)+ => Const (f1 :+: f2 :+: f3) -> Cxt h g Any a+injectConst3 = inject3 . fmap (const undefined)++projectConst :: (Difunctor g, g :<: f) => Cxt h f Any a -> Maybe (Const g)+projectConst = fmap (fmap (const ())) . project++{-| 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 (Term t) = inject $ fmap injectCxt t+injectCxt (Hole x) = x+injectCxt (Place p) = Place p++{-| This function lifts the given functor to a context. -}+liftCxt :: (Difunctor f, g :<: f) => g a b -> Cxt Hole f a b+liftCxt g = simpCxt $ inj g++instance (Show (f a b), Show (g a b)) => Show ((f :+: g) a b) where+ show (Inl v) = show v+ show (Inr v) = show v++instance (Ord (f a b), Ord (g a b)) => Ord ((f :+: g) a b) where+ compare (Inl _) (Inr _) = LT+ compare (Inr _) (Inl _) = GT+ compare (Inl x) (Inl y) = compare x y+ compare (Inr x) (Inr y) = compare x y++instance (Eq (f a b), Eq (g a b)) => Eq ((f :+: g) a b) where+ (Inl x) == (Inl y) = x == y+ (Inr x) == (Inr y) = x == y + _ == _ = False
+ src/Data/Comp/Param/Term.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE EmptyDataDecls, GADTs, KindSignatures, RankNTypes,+ MultiParamTypeClasses #-}+--------------------------------------------------------------------------------+-- |+-- Module : Data.Comp.Param.Term+-- Copyright : (c) 2011 Patrick Bahr, Tom Hvitved+-- License : BSD3+-- Maintainer : Tom Hvitved <hvitved@diku.dk>+-- Stability : experimental+-- Portability : non-portable (GHC Extensions)+--+-- This module defines the central notion of /parametrized terms/ and their+-- generalisation to parametrised contexts.+--+--------------------------------------------------------------------------------++module Data.Comp.Param.Term+ (+ Cxt(..),+ Hole,+ NoHole,+ Any,+ Term,+ Trm,+ Context,+ Const,+ simpCxt,+ coerceCxt,+ toCxt,+ constTerm,+ fmapCxt,+ disequenceCxt,+ dimapMCxt+ ) where++import Prelude hiding (mapM, sequence, foldl, foldl1, foldr, foldr1)+import Data.Comp.Param.Any+import Data.Comp.Param.Difunctor+import Data.Comp.Param.Ditraversable+import Control.Monad+import Unsafe.Coerce++{-| 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+ Term :: f a (Cxt h f a b) -> Cxt h f a b+ Hole :: b -> Cxt Hole f a b+ Place :: 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, but must be parametric in the bound+ parameters. Parametricity is \"emulated\" using the empty type @Any@, e.g. a+ function of type @Any -> T[Any]@ is equivalent with @forall b. b -> T[b]@,+ but the former avoids the impredicative typing extension, and works also in+ the cases where the codomain type is not a type constructor, e.g.+ @Any -> (Any,Any)@. -}+type Context = Cxt Hole++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. Parametricity is \"emulated\"+ using the empty type @Any@, e.g. a function of type @Any -> T[Any]@ is+ equivalent with @forall b. b -> T[b]@, but the former avoids the impredicative+ typing extension, and works also in the cases where the codomain type is not a+ type constructor, e.g. @Any -> (Any,Any)@. -}+type Term f = Trm f Any++{-| Convert a difunctorial value into a context. -}+simpCxt :: Difunctor f => f a b -> Cxt Hole f a b+{-# INLINE simpCxt #-}+simpCxt = Term . fmap Hole++{-| Cast a \"pseudo-parametric\" context over a signature to a parametric+ context over the same signature. The usage of 'unsafeCoerce' is safe, because+ the empty type 'Any' witnesses that all uses of the contravariant argument are+ parametric. -}+coerceCxt :: Cxt h f Any b -> forall a. Cxt h f a b+coerceCxt = unsafeCoerce++toCxt :: Difunctor f => Trm f a -> Cxt h f a b+{-# INLINE toCxt #-}+toCxt = unsafeCoerce++{-| -}+type Const f = f Any ()++{-| 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 the+ argument type of the difunctor @f@. -}+constTerm :: Difunctor f => Const f -> Term f+constTerm = Term . fmap (const undefined)++-- | This is an instance of 'fmap' for 'Cxt'.+fmapCxt :: Difunctor f => (b -> b') -> Cxt h f a b -> Cxt h f a b'+fmapCxt f = run+ where run (Term t) = Term $ fmap run t+ run (Place a) = Place a+ run (Hole b) = Hole $ f b++-- | This is an instance of 'dimamM' for 'Cxt'.+dimapMCxt :: Ditraversable f m a => (b -> m b') -> Cxt h f a b -> m (Cxt h f a b')+dimapMCxt f = run+ where run (Term t) = liftM Term $ dimapM run t+ run (Place a) = return $ Place a+ run (Hole b) = liftM Hole (f b)++-- | This is an instance of 'disequence' for 'Cxt'.+disequenceCxt :: Ditraversable f m a => Cxt h f a (m b) -> m (Cxt h f a b)+disequenceCxt (Term t) = liftM Term $ dimapM disequenceCxt t+disequenceCxt (Place a) = return $ Place a+disequenceCxt (Hole b) = liftM Hole b
− src/Data/Comp/Product.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances,- UndecidableInstances, RankNTypes, GADTs #-}------------------------------------------------------------------------------------ |--- Module : Data.Comp.Product--- Copyright : (c) 2010-2011 Patrick Bahr--- License : BSD3--- Maintainer : Patrick Bahr <paba@diku.dk>--- Stability : experimental--- Portability : non-portable (GHC Extensions)------ This module defines products on signatures.--------------------------------------------------------------------------------------module Data.Comp.Product- ( (:&:) (..),- (:*:) (..),- DistProd (..),- RemoveP (..),- liftP,- liftP',- stripP,- productTermHom,- constP,- project'- )where--import Data.Comp.Term-import Data.Comp.Sum-import Data.Comp.Ops-import Data.Comp.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- product. -}--liftP :: (RemoveP s s') => (s' a -> t) -> s a -> t-liftP f v = f (removeP 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- product. -}-liftP' :: (DistProd s' p s, Functor s, Functor s')- => (s' a -> Cxt h s' a) -> s a -> Cxt h s a-liftP' f v = let (v',p) = projectP v- in constP p (f v')- -{-| Strip the products from a term over a functor with products. -}-stripP :: (Functor f, RemoveP g f, Functor g) => Cxt h g a -> Cxt h f a-stripP = appSigFun removeP--{-| Lift a term homomorphism over signatures @f@ and @g@ to a term homomorphism- over the same signatures, but extended with products. -}-productTermHom :: (DistProd f p f', DistProd g p g', Functor g, Functor g') - => TermHom f g -> TermHom f' g'-productTermHom alg f' = constP p (alg f)- where (f,p) = projectP f'--{-| Annotate each node of a term with a constant value. -}-constP :: (DistProd f p g, Functor f, Functor g) - => p -> Cxt h f a -> Cxt h g a-constP c = appSigFun (injectP c)--{-| This function is similar to 'project' but applies to signatures-with a product which is then ignored. -}--- bug in type checker? below is the inferred type, however, the type checker--- rejects it.--- project' :: (RemoveP f g, f :<: f1) => Cxt h f1 a -> Maybe (g (Cxt h f1 a))-project' v = liftM removeP $ project v
src/Data/Comp/Show.hs view
@@ -18,8 +18,7 @@ ) where import Data.Comp.Term-import Data.Comp.Sum-import Data.Comp.Product+import Data.Comp.Annotation import Data.Comp.Algebra import Data.Comp.Derive @@ -33,8 +32,5 @@ instance (ShowF f, Show p) => ShowF (f :&: p) where showF (v :&: p) = showF v ++ " :&: " ++ show p -instance (ShowF f, ShowF g) => ShowF (f :+: g) where- showF (Inl f) = showF f- showF (Inr g) = showF g--$(derive [instanceShowF] [''Maybe, ''[], ''(,)])+$(derive [liftSum] [''ShowF])+$(derive [makeShowF] [''Maybe, ''[], ''(,)])
src/Data/Comp/Sum.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE TypeOperators, MultiParamTypeClasses, IncoherentInstances,- FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,- ScopedTypeVariables #-}-+ FlexibleInstances, FlexibleContexts, GADTs, TypeSynonymInstances,+ ScopedTypeVariables, TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Sum@@ -17,31 +16,72 @@ module Data.Comp.Sum (- (:<:)(..),- (:+:)(..),+ (:<:),+ (:+:), -- * 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,- 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, -- * Injections and Projections for Constants injectConst,@@ -57,128 +97,72 @@ import Data.Comp.Term import Data.Comp.Algebra import Data.Comp.Ops--import Control.Monad hiding (sequence)-import Prelude hiding (sequence)+import Data.Comp.Derive.Projections+import Data.Comp.Derive.Injections +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 -{-| A variant of 'proj' for binary sum signatures. -}-proj2 :: forall f g1 g2 a. (g1 :<: f, g2 :<: f) => f a -> Maybe ((g1 :+: g2) a)-proj2 x = case proj x of- Just (y :: g1 a) -> Just $ inj y- _ -> liftM inj (proj x :: Maybe (g2 a)) -{-| A variant of 'proj' for ternary sum signatures. -}-proj3 :: forall f g1 g2 g3 a. (g1 :<: f, g2 :<: f, g3 :<: f) => f a- -> Maybe ((g1 :+: g2 :+: g3) a)-proj3 x = case proj x of- Just (y :: g1 a) -> Just $ inj y- _ -> case proj x of- Just (y :: g2 a) -> Just $ inj y- _ -> liftM inj (proj x :: Maybe (g3 a))+$(liftM concat $ mapM projn [2..10]) --- |Project the outermost layer of a term to a sub signature.+-- |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 the outermost layer of a term to a binary sub signature.-project2 :: (g1 :<: f, g2 :<: f) => Cxt h f a -> Maybe ((g1 :+: g2) (Cxt h f a))-project2 (Hole _) = Nothing-project2 (Term t) = proj2 t---- |Project the outermost layer of a term to a ternary sub signature.-project3 :: (g1 :<: f, g2 :<: f, g3 :<: f) => Cxt h f a- -> Maybe ((g1 :+: g2 :+: g3) (Cxt h f a))-project3 (Hole _) = Nothing-project3 (Term t) = proj3 t---- |Project a term to a term over a sub signature.-deepProject :: (Traversable f, Functor g, g :<: f) => Cxt h f a- -> Maybe (Cxt h g a)-deepProject = appSigFunM proj---- |Project a term to a term over a binary sub signature.-deepProject2 :: (Traversable f, Functor g1, Functor g2, g1 :<: f, g2 :<: f) => Cxt h f a -> Maybe (Cxt h (g1 :+: g2) a)-deepProject2 = appSigFunM proj2---- |Project a term to a term over a ternary sub signature.-deepProject3 :: (Traversable f, Functor g1, Functor g2, Functor g3,- g1 :<: f, g2 :<: f, g3 :<: f) => Cxt h f a- -> Maybe (Cxt h (g1 :+: g2 :+: g3) a)-deepProject3 = appSigFunM proj3---- |A variant of 'deepProject' where the sub signature is required to be--- 'Traversable' rather than the whole signature.-deepProject' :: forall g f h a. (Traversable g, g :<: f) => Cxt h f a- -> Maybe (Cxt h g a)-deepProject' val = do- v <- project val- v' <- sequence (fmap deepProject' v :: g (Maybe (Cxt h g a)))- return $ Term v'---- |A variant of 'deepProject2' where the sub signatures are required to be--- 'Traversable' rather than the whole signature.-deepProject2' :: forall g1 g2 f h a. (Traversable g1, Traversable g2,- g1 :<: f, g2 :<: f) => Cxt h f a- -> Maybe (Cxt h (g1 :+: g2) a)-deepProject2' val = do- v <- project2 val- v' <- sequence (fmap deepProject2' v :: (g1 :+: g2) (Maybe (Cxt h (g1 :+: g2) a)))- return $ Term v'+$(liftM concat $ mapM projectn [2..10]) --- |A variant of 'deepProject3' where the sub signatures are required to be--- 'Traversable' rather than the whole signature.-deepProject3' :: forall g1 g2 g3 f h a. (Traversable g1, Traversable g2,- Traversable g3, g1 :<: f, g2 :<: f,- g3 :<: f) => Cxt h f a- -> Maybe (Cxt h (g1 :+: g2 :+: g3) a)-deepProject3' val = do- v <- project3 val- v' <- sequence (fmap deepProject3' v :: (g1 :+: g2 :+: g3) (Maybe (Cxt h (g1 :+: g2 :+: g3) a)))- return $ Term v'+-- | 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, g :<: f) => CxtFunM Maybe f g+{-# INLINE deepProject #-}+deepProject = appSigFunM' proj -{-| A variant of 'inj' for binary sum signatures. -}-inj2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) a -> g a-inj2 (Inl x) = inj x-inj2 (Inr y) = inj y+$(liftM concat $ mapM deepProjectn [2..10])+{-# INLINE deepProject2 #-}+{-# INLINE deepProject3 #-}+{-# INLINE deepProject4 #-}+{-# INLINE deepProject5 #-}+{-# INLINE deepProject6 #-}+{-# INLINE deepProject7 #-}+{-# INLINE deepProject8 #-}+{-# INLINE deepProject9 #-}+{-# INLINE deepProject10 #-} -{-| A variant of 'inj' for ternary sum signatures. -}-inj3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) a -> g a-inj3 (Inl x) = inj x-inj3 (Inr y) = inj2 y+$(liftM concat $ mapM injn [2..10]) --- |Inject a term where the outermost layer is a sub signature.+-- |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 a term where the outermost layer is a binary sub signature.-inject2 :: (f1 :<: g, f2 :<: g) => (f1 :+: f2) (Cxt h g a) -> Cxt h g a-inject2 = Term . inj2---- |Inject a term where the outermost layer is a ternary sub signature.-inject3 :: (f1 :<: g, f2 :<: g, f3 :<: g) => (f1 :+: f2 :+: f3) (Cxt h g a) -> Cxt h g a-inject3 = Term . inj3+$(liftM concat $ mapM injectn [2..10]) --- |Inject a term over a sub signature to a term over larger signature.-deepInject :: (Functor g, Functor f, g :<: f) => Cxt h g a -> Cxt h f a+-- |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 --- |Inject a term over a binary sub signature to a term over larger signature.-deepInject2 :: (Functor f1, Functor f2, Functor g, f1 :<: g, f2 :<: g)- => Cxt h (f1 :+: f2) a -> Cxt h g a-deepInject2 = appSigFun inj2---- |Inject a term over a ternary signature to a term over larger signature.-deepInject3 :: (Functor f1, Functor f2, Functor f3, Functor g,- f1 :<: g, f2 :<: g, f3 :<: g)- => Cxt h (f1 :+: f2 :+: f3) a -> Cxt h g a-deepInject3 = appSigFun inj3+$(liftM concat $ mapM deepInjectn [2..10])+{-# INLINE deepInject2 #-}+{-# INLINE deepInject3 #-}+{-# INLINE deepInject4 #-}+{-# INLINE deepInject5 #-}+{-# INLINE deepInject6 #-}+{-# INLINE deepInject7 #-}+{-# INLINE deepInject8 #-}+{-# INLINE deepInject9 #-}+{-# INLINE deepInject10 #-} injectConst :: (Functor g, g :<: f) => Const g -> Cxt h f a injectConst = inject . fmap (const undefined)@@ -195,7 +179,6 @@ projectConst = fmap (fmap (const ())) . project {-| This function injects a whole context into another context. -}- injectCxt :: (Functor g, g :<: f) => Cxt h' g (Cxt h f a) -> Cxt h f a injectCxt = cata' inject
src/Data/Comp/Term.hs view
@@ -102,33 +102,37 @@ type PTerm f = forall h a . Cxt h f a instance Functor f => Functor (Cxt h f) where- fmap f (Hole v) = Hole (f v)- fmap f (Term t) = Term (fmap (fmap f) t)+ fmap f = run+ where run (Hole v) = Hole (f v)+ run (Term t) = Term (fmap run t) instance (Foldable f) => Foldable (Cxt h f) where- foldr op e (Hole a) = a `op` e- foldr op e (Term t) = foldr op' e t- where op' c a = foldr op a c+ foldr op c a = run a c+ where run (Hole a) e = a `op` e+ run (Term t) e = foldr run e t - foldl op e (Hole a) = e `op` a- foldl op e (Term t) = foldl op' e t- where op' = foldl op+ foldl op = run+ where run e (Hole a) = e `op` a+ run e (Term t) = foldl run e t fold (Hole a) = a fold (Term t) = foldMap fold t - foldMap f (Hole a) = f a- foldMap f (Term t) = foldMap (foldMap f) t+ foldMap f = run+ where run (Hole a) = f a+ run (Term t) = foldMap run t instance (Traversable f) => Traversable (Cxt h f) where- traverse f (Hole a) = Hole <$> f a- traverse f (Term t) = Term <$> traverse (traverse f) t+ 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 (Hole a) = liftM Hole $ f a- mapM f (Term t) = liftM Term $ mapM (mapM f) t+ mapM f = run + where run (Hole a) = liftM Hole $ f a+ run (Term t) = liftM Term $ mapM run t sequence (Hole a) = liftM Hole a sequence (Term t) = liftM Term $ mapM sequence t
src/Data/Comp/Variables.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, GADTs, FlexibleInstances,- OverlappingInstances, TypeOperators #-}+ OverlappingInstances, TypeOperators, TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Comp.Variables@@ -10,7 +10,8 @@ -- Portability : non-portable (GHC Extensions) -- -- This module defines an abstract notion of (bound) variables in compositional--- data types, and capture-avoiding substitution.+-- data types, and scoped substitution. Capture-avoidance is /not/ taken into+-- account. -- -------------------------------------------------------------------------------- module Data.Comp.Variables@@ -29,8 +30,8 @@ ) where import Data.Comp.Term-import Data.Comp.Sum import Data.Comp.Algebra+import Data.Comp.Derive import Data.Foldable hiding (elem, notElem) import Data.Maybe import Data.Set (Set)@@ -54,11 +55,7 @@ bindsVars :: f a -> [v] bindsVars _ = [] -instance (HasVars f v, HasVars g v) => HasVars (f :+: g) v where- isVar (Inl v) = isVar v- isVar (Inr v) = isVar v- bindsVars (Inl v) = bindsVars v- bindsVars (Inr v) = bindsVars v+$(derive [liftSum] [''HasVars]) instance HasVars f v => HasVars (Cxt h f) v where isVar (Term t) = isVar t@@ -74,7 +71,7 @@ let vars' = vars ++ bindsVars t in case isVar t of Just v ->- -- Check for capture-avoidance+ -- Check for scope if v `elem` vars' then Term $ fmap (\x -> x vars') t else@@ -145,7 +142,7 @@ where substAlg :: (HasVars f v) => (v -> Maybe (Cxt h f a)) -> Alg f (Cxt h f a) substAlg f t = fromMaybe (Term t) (isVar t >>= f)- res :: Eq v => [v] -> (v -> Maybe t) -> (v -> Maybe t)+ res :: Eq v => [v] -> (v -> Maybe t) -> v -> Maybe t res vars f x = if x `elem` vars then Nothing else f x instance (SubstVars v t a, Functor f) => SubstVars v t (f a) where
+ testsuite/tests/Data/Comp/Examples/Comp.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TypeOperators #-}+module Data.Comp.Examples.Comp where++import qualified Examples.Eval as Eval+import qualified Examples.EvalM as EvalM+import qualified Examples.DesugarEval as DesugarEval+import qualified Examples.DesugarPos as DesugarPos++import Data.Comp++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.Utils++++++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++tests = testGroup "Compositional Data Types" [+ testProperty "eval" evalTest,+ testProperty "evalM" evalMTest,+ testProperty "desugarEval" desugarEvalTest,+ testProperty "desugarPos" desugarPosTest+ ]+++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++instance (EqF f, Eq p) => EqF (f :&: p) where+ eqF (v1 :&: p1) (v2 :&: p2) = p1 == p2 && v1 `eqF` v2++evalTest = Eval.evalEx == Eval.iConst 5+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 5)+desugarEvalTest = DesugarEval.evalEx == DesugarEval.iPair (DesugarEval.iConst 2) (DesugarEval.iConst 1)+desugarPosTest = DesugarPos.desugPEx ==+ DesugarPos.iAPair+ (DesugarPos.Pos 1 0)+ (DesugarPos.iASnd+ (DesugarPos.Pos 1 0)+ (DesugarPos.iAPair+ (DesugarPos.Pos 1 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))+ (DesugarPos.iAFst+ (DesugarPos.Pos 1 0)+ (DesugarPos.iAPair+ (DesugarPos.Pos 1 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))
+ testsuite/tests/Data/Comp/Examples/Multi.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeOperators #-}+module Data.Comp.Examples.Multi where++import qualified Examples.Multi.Eval as Eval+import qualified Examples.Multi.EvalI as EvalI+import qualified Examples.Multi.EvalM as EvalM+import qualified Examples.Multi.DesugarEval as DesugarEval+import qualified Examples.Multi.DesugarPos as DesugarPos++import Data.Comp.Multi++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.Utils++++++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++tests = testGroup "Generalised Compositional Data Types" [+ testProperty "eval" evalTest,+ testProperty "evalI" evalITest,+ testProperty "evalM" evalMTest,+ testProperty "desugarEval" desugarEvalTest,+ testProperty "desugarPos" desugarPosTest+ ]+++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++instance (HEqF f, Eq p) => HEqF (f :&: p) where+ heqF (v1 :&: p1) (v2 :&: p2) = p1 == p2 && v1 `heqF` v2++evalTest = Eval.evalEx == Eval.iConst 2+evalITest = EvalI.evalIEx == 2+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 5)+desugarEvalTest = DesugarEval.evalEx == DesugarEval.iPair (DesugarEval.iConst 2) (DesugarEval.iConst 1)+desugarPosTest = DesugarPos.desugPEx ==+ DesugarPos.iAPair+ (DesugarPos.Pos 1 0)+ (DesugarPos.iASnd+ (DesugarPos.Pos 1 0)+ (DesugarPos.iAPair+ (DesugarPos.Pos 1 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))+ (DesugarPos.iAFst+ (DesugarPos.Pos 1 0)+ (DesugarPos.iAPair+ (DesugarPos.Pos 1 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 2) 1)+ (DesugarPos.iAConst (DesugarPos.Pos 1 3) 2)))
+ testsuite/tests/Data/Comp/Examples/MultiParam.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TypeOperators #-}+module Data.Comp.Examples.MultiParam where++import qualified Examples.MultiParam.Eval as Eval+import qualified Examples.MultiParam.EvalI as EvalI+import qualified Examples.MultiParam.EvalM as EvalM+import qualified Examples.MultiParam.EvalAlgM as EvalAlgM+import qualified Examples.MultiParam.DesugarEval as DesugarEval+import qualified Examples.MultiParam.DesugarPos as DesugarPos++import Data.Comp.MultiParam++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.Utils++++++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++tests = testGroup "Parametric Compositional Data Types" [+ testProperty "eval" evalTest,+ testProperty "evalI" evalITest,+ testProperty "evalM" evalMTest,+ testProperty "evalAlgM" evalAlgMTest,+ testProperty "desugarEval" desugarEvalTest,+ testProperty "desugarPos" desugarPosTest+ ]+++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------++instance (EqHD f, Eq p) => EqHD (f :&: p) where+ eqHD (v1 :&: p1) (v2 :&: p2) = do b <- eqHD v1 v2+ return $ p1 == p2 && b++evalTest = Eval.evalEx == Just (Eval.iConst 4)+evalITest = EvalI.evalEx == 4+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 12)+evalAlgMTest = EvalAlgM.evalMEx == Just (EvalAlgM.iConst 5)+desugarEvalTest = DesugarEval.evalEx == Just (DesugarEval.iConst (-6))+desugarPosTest = DesugarPos.desugPEx ==+ DesugarPos.iAApp (DesugarPos.Pos 1 0)+ (DesugarPos.iALam (DesugarPos.Pos 1 0) $ \x -> DesugarPos.iAMult (DesugarPos.Pos 1 2) (DesugarPos.iAConst (DesugarPos.Pos 1 2) (-1)) (Place x))+ (DesugarPos.iAConst (DesugarPos.Pos 1 1) 6)
+ testsuite/tests/Data/Comp/Examples/Param.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TypeOperators #-}+module Data.Comp.Examples.Param where++import qualified Examples.Param.Eval as Eval+import qualified Examples.Param.EvalM as EvalM+import qualified Examples.Param.EvalAlgM as EvalAlgM+import qualified Examples.Param.DesugarEval as DesugarEval+import qualified Examples.Param.DesugarPos as DesugarPos+import qualified Examples.Param.Parsing as Parsing++import Data.Comp.Param++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.Utils++++++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++tests = testGroup "Parametric Compositional Data Types" [+ testProperty "eval" evalTest,+ testProperty "evalM" evalMTest,+ testProperty "evalAlgM" evalAlgMTest,+ testProperty "desugarEval" desugarEvalTest,+ testProperty "desugarPos" desugarPosTest,+ testProperty "parsing" parsingTest+ ]+++--------------------------------------------------------------------------------+-- 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++evalTest = Eval.evalEx == Just (Eval.iConst 4)+evalMTest = EvalM.evalMEx == Just (EvalM.iConst 12)+evalAlgMTest = EvalAlgM.evalMEx == Just (EvalAlgM.iConst 5)+desugarEvalTest = DesugarEval.evalEx == Just (DesugarEval.iConst 720)+desugarPosTest = DesugarPos.desugPEx ==+ DesugarPos.iAApp (DesugarPos.Pos 1 0)+ (DesugarPos.iALam (DesugarPos.Pos 1 0) Place)+ (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \f ->+ DesugarPos.iAApp (DesugarPos.Pos 1 1)+ (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \x ->+ DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place f) (DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place x) (Place x)))+ (DesugarPos.iALam (DesugarPos.Pos 1 1) $ \x ->+ DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place f) (DesugarPos.iAApp (DesugarPos.Pos 1 1) (Place x) (Place x))))+parsingTest = Parsing.transEx == (Parsing.iLam $ \a -> Parsing.iApp (Parsing.iLam $ \b -> Parsing.iLam $ \c -> Place b) (Place a))
+ testsuite/tests/Data/Comp/Examples_Test.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TypeOperators #-}+module Data.Comp.Examples_Test where++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+ ]
testsuite/tests/Data/Comp_Test.hs view
@@ -12,7 +12,7 @@ import Test.Utils import qualified Data.Comp.Equality_Test-+import qualified Data.Comp.Examples_Test -------------------------------------------------------------------------------- -- Test Suits@@ -21,7 +21,8 @@ main = defaultMain [tests] tests = testGroup "Comp" [- Data.Comp.Equality_Test.tests+ Data.Comp.Equality_Test.tests,+ Data.Comp.Examples_Test.tests ] --------------------------------------------------------------------------------
testsuite/tests/Test/Utils.hs view
@@ -16,7 +16,7 @@ data Pair a e = Pair a e $(derive- [instanceFunctor, instanceFoldable, instanceShowF, instanceEqF, instanceArbitraryF]+ [makeFunctor, makeFoldable, makeShowF, makeEqF, makeArbitraryF] [''Tree, ''Pair]) $(derive