github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-18 20:31:55 +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 , ofWeight
) where ) where
import Control.Comonad.Cofree as Cofree
import Control.Comonad.Trans.Cofree as CofreeF
import Control.Monad.Free as Free import Control.Monad.Free as Free
import Control.Monad.Trans.Free as FreeF import Control.Monad.Trans.Free as FreeF
import Data.Bifunctor.Join import Data.Bifunctor.Join
@ -116,17 +114,6 @@ instance Listable2 p => Listable1 (Join p) where
instance Listable2 These where instance Listable2 These where
liftTiers2 this that = liftCons1 this This \/ liftCons1 that That \/ liftCons2 this that These 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 instance Listable1 f => Listable2 (FreeF f) where
liftTiers2 pureTiers recurTiers = liftCons1 pureTiers FreeF.Pure \/ liftCons1 (liftTiers recurTiers) FreeF.Free 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.Align.Generic
import Data.Bifunctor import Data.Bifunctor
import Data.Functor.Both 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.Foldable
import Data.Functor.Listable
import Data.Maybe import Data.Maybe
import Data.Proxy import Data.Proxy
import Data.Record 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) hoistCofree f = go where go (a :< r) = a :< f (fmap go r)
instance Pretty1 f => Pretty1 (Term f) where 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 instance (Pretty1 f, Pretty a) => Pretty (Term f a) where
pretty = liftPretty pretty prettyList 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 instance Functor f => Bifunctor (TermF f) where
bimap f g (a :<< r) = f a :<< fmap g r 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