github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-23 14:54:16 +03:00
Code Issues Projects Releases Wiki Activity

Define a Listable newtype wrapper for Listable1 type applications.

Browse Source
This commit is contained in:
Rob Rix 2017-01-07 09:13:40 -05:00
parent a9ba058cf9
commit ddaa2d2d18
1 changed files with 7 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,6 +16,7 @@ module Data.Functor.Listable
, liftCons2
, liftCons3
, liftCons4
, ListableF(..)
) where
import Data.Bifunctor.Join
@ -51,6 +52,9 @@ liftCons4 :: [[a]] -> [[b]] -> [[c]] -> [[d]] -> (a -> b -> c -> d -> e) -> [[e]
liftCons4 tiers1 tiers2 tiers3 tiers4 f = mapT (uncurry4 f) (productWith (\ x (y, z, w) -> (x, y, z, w)) tiers1 (liftCons3 tiers2 tiers3 tiers4 (,,)) ) `addWeight` 1
where uncurry4 f (a, b, c, d) = f a b c d
newtype ListableF f a = ListableF { unListableF :: f a }
deriving Show
-- Instances
@ -95,3 +99,6 @@ instance (Listable1 f, Listable a) => Listable1 (FreeF f a) where
instance Listable1 f => Listable1 (Free f) where
liftTiers pureTiers = go
where go = liftCons1 (liftTiers2 pureTiers go) free
instance (Listable1 f, Listable a) => Listable (ListableF f a) where
tiers = ListableF `mapT` tiers1