github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-18 12:21:57 +03:00
Code Issues Projects Releases Wiki Activity

Define Listable instances for Term/TermF.

Browse Source
This commit is contained in:
Rob Rix 2017-09-08 16:50:21 +01:00
parent 185818d8bd
commit ea5107c484
2 changed files with 13 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Data/Functor/Listable.hs
View File

@ -24,8 +24,6 @@ module Data.Functor.Listable
, ofWeight
) where
import Control.Comonad.Cofree as Cofree
import Control.Comonad.Trans.Cofree as CofreeF
import Control.Monad.Free as Free
import Control.Monad.Trans.Free as FreeF
import Data.Bifunctor.Join
@ -116,17 +114,6 @@ instance Listable2 p => Listable1 (Join p) where
instance Listable2 These where
liftTiers2 this that = liftCons1 this This \/ liftCons1 that That \/ liftCons2 this that These
instance Listable1 f => Listable2 (CofreeF f) where
liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (CofreeF.:<)
instance (Listable1 f, Listable a) => Listable1 (CofreeF f a) where
liftTiers = liftTiers2 tiers
instance (Functor f, Listable1 f) => Listable1 (Cofree.Cofree f) where
liftTiers annotationTiers = go
where go = liftCons1 (liftTiers2 annotationTiers go) cofree
cofree (a CofreeF.:< f) = a Cofree.:< f
instance Listable1 f => Listable2 (FreeF f) where
liftTiers2 pureTiers recurTiers = liftCons1 pureTiers FreeF.Pure \/ liftCons1 (liftTiers recurTiers) FreeF.Free

15
src/Term.hs
View File

@ -21,8 +21,9 @@ import Control.Monad.Free
import Data.Align.Generic
import Data.Bifunctor
import Data.Functor.Both
import Data.Functor.Classes.Pretty.Generic
import Data.Functor.Classes.Pretty.Generic as Pretty
import Data.Functor.Foldable
import Data.Functor.Listable
import Data.Maybe
import Data.Proxy
import Data.Record
@ -80,7 +81,7 @@ hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a
hoistCofree f = go where go (a :< r) = a :< f (fmap go r)
instance Pretty1 f => Pretty1 (Term f) where
liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f
liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (Pretty.list . map (liftPretty p pl)) f
instance (Pretty1 f, Pretty a) => Pretty (Term f a) where
pretty = liftPretty pretty prettyList
@ -113,3 +114,13 @@ instance (Show (f (Term f a)), Show a) => Show (Term f a) where
instance Functor f => Bifunctor (TermF f) where
bimap f g (a :<< r) = f a :<< fmap g r
instance Listable1 f => Listable2 (TermF f) where
liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<<)
instance (Listable1 f, Listable a) => Listable1 (TermF f a) where
liftTiers = liftTiers2 tiers
instance (Functor f, Listable1 f) => Listable1 (Term f) where
liftTiers annotationTiers = go
where go = liftCons1 (liftTiers2 annotationTiers go) cofree