packages feed

extensible 0.3.1 → 0.3.2

raw patch · 13 files changed

+172/−181 lines, 13 files

Files

CHANGELOG.md view
@@ -1,3 +1,12 @@+0.3.2+-----------------------------------------------------+* Added `Associate` class and combinators around it+* `Data.Extensible.Record` now lets values be independent from keys+    * `mkField` requires 1 argument+* Added `Data.Extensible.Union`, partially taking `elevator`'s functionality+* Removed old `Data.Extensible.Union` and `Data.Extensible.League`+* Removed `(<?!)`+ 0.3.1 ----------------------------------------------------- * Removed `Reifiable`
examples/records.hs view
@@ -3,16 +3,16 @@ import Data.Extensible import Control.Lens -mkField "name" [t|String|]-mkField "weight" [t|Float|]-mkField "price" [t|Int|]-mkField "description" [t|String|]-mkField "featured" [t|Bool|]-mkField "quantity" [t|Int|]+mkField "name weight price description featured quantity" -type Stock = Record '["name", "weight", "price", "featured", "description", "quantity"]+type Stock c = Record '["name" :> String+  , "weight" :> Float+  , "price" :> c+  , "featured" :> Bool+  , "description" :> String+  , "quantity" :> Int] -s0 :: Stock+s0 :: Num c => Stock c s0 = Field "DA-192H"   <: Field 260   <: Field 120@@ -22,14 +22,14 @@   <: Nil  -- Use shrink to permute elements-s1 :: Stock-s1 = shrink+s1 :: Num c => Stock c+s1 = shrinkAssoc    $ name @= "HHP-150"   <: featured @= False   <: description @= "Premium wooden headphone"-  <: weight @= 150   <: price @= 330   <: quantity @= 55+  <: weight @= 200   <: Nil  -- If "quantity" is missing,@@ -38,5 +38,5 @@ -- If there are duplicate "quantity", --    Couldn't match type ‘Ambiguous "quantity"’ with ‘Expecting one’ -printSummary :: ("name" ∈ s, "description" ∈ s) => Record s -> IO ()+printSummary :: (Associate "name" String s, Associate "description" String s) => Record s -> IO () printSummary s = putStrLn $ view name s ++ ": " ++ view description s
extensible.cabal view
@@ -1,5 +1,5 @@ name:                extensible-version:             0.3.1+version:             0.3.2 synopsis:            Extensible, efficient, lens-friendly data types homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -29,17 +29,16 @@ library   exposed-modules:     Data.Extensible+    Data.Extensible.Dictionary     Data.Extensible.Inclusion     Data.Extensible.Internal     Data.Extensible.Internal.Rig-    Data.Extensible.Dictionary-    Data.Extensible.League     Data.Extensible.Match     Data.Extensible.Plain     Data.Extensible.Product+    Data.Extensible.Record     Data.Extensible.Sum     Data.Extensible.Union-    Data.Extensible.Record   default-extensions: TypeOperators     , DeriveDataTypeable     , KindSignatures@@ -50,6 +49,7 @@     , FlexibleContexts     , FlexibleInstances     , PolyKinds+    , CPP   build-depends:       base >= 4.7 && <5, template-haskell, binary < 1, constraints   hs-source-dirs:      src   ghc-options: -Wall -O2
src/Data/Extensible.hs view
@@ -25,13 +25,11 @@   -- * Reexport   module Data.Extensible.Dictionary   , module Data.Extensible.Inclusion-  , module Data.Extensible.League   , module Data.Extensible.Match   , module Data.Extensible.Plain   , module Data.Extensible.Record   , module Data.Extensible.Product   , module Data.Extensible.Sum-  , module Data.Extensible.Union   , Comp(..)   , comp   ) where@@ -40,8 +38,6 @@ import Data.Extensible.Plain import Data.Extensible.Product import Data.Extensible.Sum-import Data.Extensible.League-import Data.Extensible.Union import Data.Extensible.Record import Data.Extensible.Internal.Rig import Data.Extensible.Dictionary
src/Data/Extensible/Inclusion.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Inclusion@@ -21,13 +22,20 @@   , Missing   , Ambiguous   , ord+  , Assoc(..)+  , Associate(..)   -- * Inclusion   , (⊆)()   , Include   , inclusion   , shrink-  , subset   , spread+  -- * Dictionary-like+  , IncludeAssoc+  , Associated+  , inclusionAssoc+  , shrinkAssoc+  , spreadAssoc   -- * Inverse   , coinclusion   , wrench@@ -58,13 +66,6 @@ shrink h = hmap (`hlookup` h) inclusion {-# INLINE shrink #-} --- | A lens for a subset (inefficient)-subset :: (xs ⊆ ys) => Lens' (h :* ys) (h :* xs)-subset f ys = fmap (write ys) $ f (shrink ys) where-  write y xs = flip appEndo y-    $ hfoldMap getConst'-    $ hzipWith (\dst src -> Const' $ Endo $ sectorAt dst `over` const src) inclusion xs- -- | /O(log n)/ Embed to a larger union. spread :: (xs ⊆ ys) => h :| xs -> h :| ys spread (UnionAt pos h) = views (sectorAt pos) UnionAt inclusion h@@ -86,3 +87,28 @@ retrench :: (Generate ys, xs ⊆ ys) => h :| ys -> Nullable ((:|) h) xs retrench (UnionAt pos h) = views (sectorAt pos) (mapNullable (`UnionAt`h)) coinclusion {-# INLINE retrench #-}++------------------------------------------------------------------++class Associated xs t where+  getAssociation :: Membership xs t++instance Associate k v xs => Associated xs (k ':> v) where+  getAssociation = association++-- | Similar to 'Include', but works nicely for key-value pairs.+type IncludeAssoc ys xs = Forall (Associated ys) xs++-- | Reify the inclusion of type level sets.+inclusionAssoc :: forall xs ys. IncludeAssoc ys xs => Membership ys :* xs+inclusionAssoc = htabulateFor (Proxy :: Proxy (Associated ys)) (const getAssociation)++-- | /O(m log n)/ Select some elements.+shrinkAssoc :: (IncludeAssoc ys xs) => h :* ys -> h :* xs+shrinkAssoc h = hmap (`hlookup` h) inclusionAssoc+{-# INLINE shrinkAssoc #-}++-- | /O(log n)/ Embed to a larger union.+spreadAssoc :: (IncludeAssoc ys xs) => h :| xs -> h :| ys+spreadAssoc (UnionAt pos h) = views (sectorAt pos) UnionAt inclusionAssoc h+{-# INLINE spreadAssoc #-}
src/Data/Extensible/Internal.hs view
@@ -34,6 +34,9 @@   , ToInt(..)   , Lookup   , ListIndex+  , Assoc(..)+  , AssocKeys+  , Associate(..)   , LookupTree(..)   , Succ   , MapSucc@@ -57,14 +60,17 @@   ) where import Data.Type.Equality import Data.Proxy+#if !MIN_VERSION_base(4,8,0) import Control.Applicative+import Data.Word+#endif import Control.Monad import Unsafe.Coerce import Data.Typeable import Language.Haskell.TH hiding (Pred) import Data.Bits-import Data.Word + -- | Generates a 'Membership' that corresponds to the given ordinal (0-origin). ord :: Int -> Q Exp ord n = do@@ -88,21 +94,36 @@  -- | Lookup types type family ListIndex (n :: Nat) (xs :: [k]) :: k where-  ListIndex Zero (x ': xs) = x-  ListIndex (SDNat n) (y ': xs) = ListIndex n (Half xs)-  ListIndex (DNat n) xs = ListIndex n (Half xs)+  ListIndex 'Zero (x ': xs) = x+  ListIndex ('SDNat n) (y ': xs) = ListIndex n (Half xs)+  ListIndex ('DNat n) xs = ListIndex n (Half xs)  type family Pred (n :: Nat) :: Nat where-  Pred (SDNat Zero) = Zero-  Pred (SDNat n) = DNat n-  Pred (DNat n) = SDNat (Pred n)-  Pred Zero = Zero+  Pred ('SDNat 'Zero) = 'Zero+  Pred ('SDNat n) = 'DNat n+  Pred ('DNat n) = 'SDNat (Pred n)+  Pred 'Zero = 'Zero  type family Div2 (n :: Nat) :: Nat where-  Div2 (SDNat n) = n-  Div2 (DNat n) = n-  Div2 Zero = Zero+  Div2 ('SDNat n) = n+  Div2 ('DNat n) = n+  Div2 'Zero = 'Zero +-- | The kind of key-value pairs+data Assoc k v = k :> v++type family AssocKeys (xs :: [Assoc k v]) :: [k] where+  AssocKeys ((k ':> v) ': xs) = k ': AssocKeys xs+  AssocKeys '[] = '[]++-- | @'Associate' k v xs@ is essentially identical to @(k :> v) ∈ xs@+-- , but the type @v@ is inferred from @k@ and @xs@.+class Associate k v xs | k xs -> v where+  association :: Membership xs (k ':> v)++instance (Check k (Lookup k (AssocKeys xs)) ~ Expecting one, ToInt one, (k ':> v) ~ ListIndex one xs) => Associate k v xs where+  association = Membership (theInt (Proxy :: Proxy one))+ -- | The type of extensible products. data (h :: k -> *) :* (s :: [k]) where   Nil :: h :* '[]@@ -118,16 +139,17 @@     -> (h x -> f (h x))     -> h :* xs -> f (h :* xs) -instance LookupTree Zero (x ': xs) x where+instance LookupTree 'Zero (x ': xs) x where   lookupTree _ f (Tree h a b) = fmap (\h' -> Tree h' a b) (f h)   {-# INLINE lookupTree #-} -instance LookupTree n (Half xs) x => LookupTree (SDNat n) (t ': xs) x where+instance LookupTree n (Half xs) x => LookupTree ('SDNat n) (t ': xs) x where   lookupTree _ f (Tree h a b) = fmap (\a' -> Tree h a' b) (lookupTree (Proxy :: Proxy n) f a)   {-# INLINE lookupTree #-} -instance LookupTree (Pred n) (Half (Tail xs)) x => LookupTree (DNat n) (t ': xs) x where-  lookupTree _ f (Tree h a b) = fmap (\b' -> Tree h a b') (lookupTree (Proxy :: Proxy (Div2 (Pred (DNat n)))) (unsafeCoerce f) b)+instance LookupTree (Pred n) (Half (Tail xs)) x => LookupTree ('DNat n) (t ': xs) x where+  lookupTree _ f (Tree h a b) = fmap (\b' -> Tree h a b')+    (lookupTree (Proxy :: Proxy (Div2 (Pred ('DNat n)))) (unsafeCoerce f) b)   {-# INLINE lookupTree #-}  instance Show (Membership xs x) where@@ -219,7 +241,7 @@  -- | Lookup types type family Lookup (x :: k) (xs :: [k]) :: [Nat] where-  Lookup x (x ': xs) = Zero ': Lookup x xs+  Lookup x (x ': xs) = 'Zero ': Lookup x xs   Lookup x (y ': ys) = MapSucc (Lookup x ys)   Lookup x '[] = '[] @@ -241,23 +263,23 @@ class ToInt n where   theInt :: proxy n -> Word -instance ToInt Zero where+instance ToInt 'Zero where   theInt _ = 0   {-# INLINE theInt #-} -instance ToInt n => ToInt (DNat n) where+instance ToInt n => ToInt ('DNat n) where   theInt _ = theInt (Proxy :: Proxy n) `unsafeShiftL` 1   {-# INLINE theInt #-} -instance ToInt n => ToInt (SDNat n) where+instance ToInt n => ToInt ('SDNat n) where   theInt _ = (theInt (Proxy :: Proxy n) `unsafeShiftL` 1) + 1   {-# INLINE theInt #-}  -- | The successor of the number type family Succ (x :: Nat) :: Nat where-  Succ Zero = SDNat Zero-  Succ (DNat n) = SDNat n-  Succ (SDNat n) = DNat (Succ n)+  Succ 'Zero = 'SDNat 'Zero+  Succ ('DNat n) = 'SDNat n+  Succ ('SDNat n) = 'DNat (Succ n)  -- | Ideally, it will be 'Map Succ' type family MapSucc (xs :: [Nat]) :: [Nat] where
src/Data/Extensible/Internal/Rig.hs view
@@ -13,11 +13,13 @@ ------------------------------------------------------------------------ module Data.Extensible.Internal.Rig where import Unsafe.Coerce-import Control.Applicative import Data.Typeable+import Control.Applicative+#if !MIN_VERSION_base(4,8,0) import Data.Monoid import Data.Foldable (Foldable) import Data.Traversable (Traversable)+#endif  -- | A type synonym for lenses type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
− src/Data/Extensible/League.hs 
@@ -1,51 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Data.Extensible.League--- Copyright   :  (c) Fumiaki Kinoshita 2015--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ Efficient extensible functor--------------------------------------------------------------------------module Data.Extensible.League where--import Data.Extensible.Internal-import Data.Extensible.Sum-import Data.Extensible.Product-import Data.Extensible.Match-import Data.Typeable---- | A much more efficient representation for 'Union' of 'Functor's.-newtype League fs a = League { getLeague :: Fuse a :| fs } deriving Typeable---- | fast fmap-instance Functor (League fs) where-  fmap f (League (UnionAt pos s)) = League (UnionAt pos (mapFuse f s))-  {-# INLINE fmap #-}---- | /O(log n)/ Embed a functor.-liftL :: (Functor f, f ∈ fs) => f a -> League fs a-liftL f = League $ embed $ Fuse $ \g -> fmap g f-{-# INLINE liftL #-}---- | Flipped <http://hackage.haskell.org/package/kan-extensions-4.1.0.1/docs/Data-Functor-Yoneda.html Yoneda>-newtype Fuse a f = Fuse { getFuse :: forall b. (a -> b) -> f b }---- | Fuse 'Fuse' to retract a substantial functor.-meltdown :: Fuse a f -> f a-meltdown (Fuse f) = f id-{-# INLINE meltdown #-}---- | 'fmap' for the content.-mapFuse :: (a -> b) -> Fuse a f -> Fuse b f-mapFuse f (Fuse g) = Fuse (\h -> g (h . f))-{-# INLINE mapFuse #-}---- | Prepend a clause for @'Match' ('Fuse' x)@ as well as ('<?!').-(<?!$) :: (f x -> a) -> Match (Fuse x) a :* fs -> Match (Fuse x) a :* (f ': fs)-(<?!$) f = (<:) (Match (f . meltdown))-{-# INLINE (<?!$) #-}-infixr 1 <?!$
src/Data/Extensible/Plain.hs view
@@ -21,8 +21,6 @@   , record   , recordAt   , (<?%)-  , K1(..)-  , (<?!)   , accessing   , decFields   , decFieldsDeriving@@ -31,7 +29,6 @@ import Data.Extensible.Internal.Rig import Data.Extensible.Product import Data.Extensible.Sum-import Data.Typeable import Unsafe.Coerce import Language.Haskell.TH hiding (Match(..)) import Data.Char@@ -80,14 +77,6 @@ {-# INLINE (<?%) #-} infixr 1 <?% --- | Wrap a type that has a kind @* -> *@.-newtype K1 a f = K1 { getK1 :: f a } deriving (Eq, Ord, Read, Typeable)---- | Prepend a clause for a parameterized value.-(<?!) :: (f x -> a) -> Match (K1 x) a :* xs -> Match (K1 x) a :* (f ': fs)-(<?!) = unsafeCoerce (<:*)-infixr 1 <?!- -- | An accessor for newtype constructors. accessing :: (Coercible b a, b ∈ xs) => (a -> b) -> Lens' (AllOf xs) a accessing c f = record (fmap c . f . coerce)@@ -119,7 +108,11 @@       xs <- newName "xs"       sequence [return $ NewtypeD cx name_ tvs (NormalC nc [(st, ty)]) (drv' ++ drv)         ,sigD name+#if MIN_VERSION_template_haskell(2,10,0)+          $ forallT (PlainTV xs : tvs) (sequence [conT ''Member `appT` varT xs `appT` conT name_])+#else           $ forallT (PlainTV xs : tvs) (sequence [classP ''Member [varT xs, conT name_]])+#endif           $ conT ''Lens' `appT` (conT ''AllOf `appT` varT xs) `appT` return ty         , valD (varP name) (normalB $ varE 'accessing `appE` conE nc) []         , return $ PragmaD $ InlineP name Inline FunLike AllPhases
src/Data/Extensible/Product.hs view
@@ -35,6 +35,7 @@   , hlookup   , hindex   , sector+  , sectorAssoc   , sectorAt   -- * Generation   , Generate(..)@@ -45,7 +46,9 @@ import Data.Extensible.Internal import Data.Extensible.Internal.Rig import Unsafe.Coerce+#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Data.Monoid  -- | /O(1)/ Extract the head element.@@ -164,6 +167,11 @@ sector :: (x ∈ xs) => Lens' (h :* xs) (h x) sector = sectorAt membership {-# INLINE sector #-}++-- | /O(log n)/ A lens for a specific element.+sectorAssoc :: (Associate k v xs) => Lens' (h :* xs) (h (k ':> v))+sectorAssoc = sectorAt association+{-# INLINE sectorAssoc #-}  -- | /O(log n)/ A lens for a value in a known position. sectorAt :: forall f h x xs. Functor f => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs)
src/Data/Extensible/Record.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell, TypeFamilies, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, TypeFamilies, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Record@@ -21,9 +21,8 @@   , (@=)   , (<@=>)   , mkField-  , recordType   , Field(..)-  , FieldValue+  , getField   , FieldLens   , FieldName   -- * Internal@@ -34,41 +33,43 @@ import Data.Extensible.Internal import Data.Extensible.Internal.Rig import Language.Haskell.TH-import Language.Haskell.TH.Quote import GHC.TypeLits hiding (Nat) import Data.Extensible.Inclusion import Data.Extensible.Dictionary ()---- | Associates names with concrete types.-type family FieldValue (s :: Symbol) :: *+import Control.Monad  -- | The type of fields.-data Field (s :: Symbol) = Field { getField :: FieldValue s }+data Field kv where+  Field :: v -> Field (k ':> v) +-- | Get a value of a field.+getField :: Field (k ':> v) -> v+getField (Field v) = v+ -- | The type of records which contain several fields. type Record = (:*) Field  -- | Shows in @field \@= value@ style instead of the derived one.-instance (KnownSymbol s, Show (FieldValue s)) => Show (Field s) where-  showsPrec d f@(Field a) = showParen (d >= 1) $ showString (symbolVal f)+instance (KnownSymbol k, Show v) => Show (Field (k ':> v)) where+  showsPrec d (Field a) = showParen (d >= 1) $ showString (symbolVal (Proxy :: Proxy k))     . showString " @= "     . showsPrec 1 a  -- | @FieldLens s@ is a type of lens that points a field named @s@. -- -- @--- 'FieldLens' s = (s ∈ xs) => Lens' ('Record' xs) ('FieldValue' s)+-- 'FieldLens' "foo" = Associate "foo" a xs => Lens' ('Record' xs) a -- @ ---type FieldLens s = forall f p xs. (Functor f, Labelable s p, s ∈ xs)-  => p (FieldValue s) (f (FieldValue s)) -> Record xs -> f (Record xs)+type FieldLens k = forall f p xs v. (Functor f, Labelable k p, Associate k v xs)+  => p v (f v) -> Record xs -> f (Record xs)  -- | When you see this type as an argument, it expects a 'FieldLens'. -- This type is used to resolve the name of the field internally.-type FieldName s = LabelPhantom s (FieldValue s) (Proxy (FieldValue s))-  -> Record '[s] -> Proxy (Record '[s])+type FieldName k = forall v. LabelPhantom k v (Proxy v)+  -> Record '[k ':> v] -> Proxy (Record '[k ':> v]) --- | A ghostly type which reifies the field name+-- | A ghostly type which spells the field name data LabelPhantom s a b  -- | An internal class to characterize 'FieldLens'@@ -83,47 +84,38 @@   unlabel _ = error "Impossible"  -- | Annotate a value by the field name.-(@=) :: FieldName s -> FieldValue s -> Field s+(@=) :: FieldName k -> v -> Field (k ':> v) (@=) _ = Field {-# INLINE (@=) #-} infix 1 @=  -- | Lifted ('@=')-(<@=>) :: Functor f => FieldName s -> f (FieldValue s) -> Comp f Field s+(<@=>) :: Functor f => FieldName k -> f v -> Comp f Field (k ':> v) (<@=>) _ = comp Field {-# INLINE (<@=>) #-} infix 1 <@=> +type Assoc_ a b = a ':> b+ -- | Generate a field.--- @'mkField' "foo" [t|Int|]@ defines:+-- @'mkField' "foo bar"@ defines: -- -- @--- type instance FieldValue "foo" = Int--- -- foo :: FieldLens "foo"+-- foo :: FieldLens "bar" -- @ -- -- The yielding field is a <http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Lens>.-mkField :: String -> TypeQ -> DecsQ-mkField s t = do+mkField :: String -> DecsQ+mkField str = fmap concat $ forM (words str) $ \s -> do   f <- newName "f"   let st = litT (strTyLit s)-  let vt = conT ''FieldValue `appT` st-  let fcon = sigE (conE 'Field) $ arrowT `appT` vt `appT` (conT ''Field `appT` st)+  let vt = varT (mkName "v")+  let fcon = sigE (conE 'Field) $ forallT [PlainTV $ mkName "v"] (return []) $ arrowT `appT` vt `appT` (conT ''Field `appT` (conT ''Assoc_ `appT` st `appT` vt))   let lbl = conE 'Proxy `sigE` (conT ''Proxy `appT` st)   let wf = varE '(.) `appE` (varE 'fmap `appE` fcon)         `appE` (varE '(.) `appE` (varE 'unlabel `appE` lbl `appE` varE f) `appE` varE 'getField)-  sequence [tySynInstD ''FieldValue (tySynEqn [litT (strTyLit s)] t)-    , sigD (mkName s)-      $ conT ''FieldLens `appT` st-    , funD (mkName s) [clause [varP f] (normalB $ varE 'sector `appE` wf) []]+  sequence [sigD (mkName s) $ conT ''FieldLens `appT` st+    , funD (mkName s) [clause [varP f] (normalB $ varE 'sectorAssoc `appE` wf) []]     , return $ PragmaD $ InlineP (mkName s) Inline FunLike AllPhases     ]---- | @[recordType|foo bar baz|] --> Record '["foo", "bar", "baz"]@-recordType :: QuasiQuoter-recordType = QuasiQuoter { quoteType = appT (conT ''Record) . foldr (\e t -> promotedConsT `appT` e `appT` t)-promotedNilT . map (litT . strTyLit) . words-  , quoteDec = error "Unsupported"-  , quoteExp = error "Unsupported"-  , quotePat = error "Unsupported" }
src/Data/Extensible/Sum.hs view
@@ -21,10 +21,13 @@   , (<:|)   , exhaust   , picked+  , embedAssoc   ) where  import Data.Extensible.Internal+#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#endif import Data.Typeable  -- | The extensible sum type@@ -70,3 +73,6 @@   Right Refl -> fmap (UnionAt pos) (f h)   _ -> pure u {-# INLINE picked #-}++embedAssoc :: Associate k a xs => h (k ':> a) -> h :| xs+embedAssoc = UnionAt association
src/Data/Extensible/Union.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Union@@ -8,45 +9,32 @@ -- Stability   :  experimental -- Portability :  non-portable --+-- Polymorphic open unions -------------------------------------------------------------------------module Data.Extensible.Union (-  (<?!~)-  , Union(..)-  , liftU-  , Flux(..)-  , mapFlux-  ) where+module Data.Extensible.Union where -import Data.Typeable import Data.Extensible.Internal+import Data.Extensible.Internal.Rig import Data.Extensible.Sum import Data.Extensible.Product-import Data.Extensible.Match+import Data.Typeable --- | A union of @* -> *@ types.-newtype Union fs a = Union { getUnion :: Flux a :| fs } deriving Typeable+-- | Wrap a type that has a kind @* -> *@.+newtype K1 a f = K1 { getK1 :: f a } deriving (Eq, Ord, Read, Typeable) --- | fast fmap-instance Functor (Union fs) where-  fmap f (Union (UnionAt pos s)) = Union (UnionAt pos (mapFlux f s))-  {-# INLINE fmap #-}+newtype Union xs a = Union { getUnion :: K1 a :| xs } --- | /O(log n)/ Embed a value.-liftU :: (f ∈ fs) => f a -> Union fs a-liftU = Union . embed . Flux id-{-# INLINE liftU #-}+reunion :: Gondola m :* xs -> Union xs a -> m a+reunion gs (Union (UnionAt pos (K1 f))) = views (sectorAt pos) runGondola gs f --- | Flipped <http://hackage.haskell.org/package/kan-extensions/docs/Data-Functor-Coyoneda.html Coyoneda>-data Flux a f where-  Flux :: (a -> b) -> f a -> Flux b f+-- | Transformation between effects+newtype Gondola f g = Gondola { runGondola :: forall a. g a -> f a } --- | 'fmap' for the content.-mapFlux :: (a -> b) -> Flux a f -> Flux b f-mapFlux f (Flux g m) = Flux (f . g) m-{-# INLINE mapFlux #-}+-- | Add a new transformation.+rung :: (forall x. f x -> g x) -> Gondola g :* fs -> Gondola g :* (f ': fs)+rung f = (<:) (Gondola f)+infixr 0 `rung` --- | Prepend a clause for @'Match' ('Flux' x)@ as well as ('<?!').-(<?!~) :: (forall b. f b -> (b -> x) -> a) -> Match (Flux x) a :* fs -> Match (Flux x) a :* (f ': fs)-(<?!~) f = (<:) $ Match $ \(Flux g m) -> f m g-{-# INLINE (<?!~) #-}-infixr 1 <?!~+runGondolas :: (x ∈ xs) => Gondola f :* xs -> x a -> f a+runGondolas = views sector runGondola+{-# INLINE runGondolas #-}