extensible 0.3.2 → 0.3.3

raw patch · 16 files changed

+348/−250 lines, 16 filesdep +profunctorsdep −binaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: profunctors

Dependencies removed: binary

API changes (from Hackage documentation)

Files

• .travis.yml +51/−6
• CHANGELOG.md +13/−0
• examples/records.hs +3/−2
• extensible.cabal +4/−3
• src/Data/Extensible.hs +7/−7
• src/Data/Extensible/Class.hs +37/−0
• src/Data/Extensible/Dictionary.hs +11/−12
• src/Data/Extensible/Inclusion.hs +14/−22
• src/Data/Extensible/Internal.hs +52/−101
• src/Data/Extensible/Internal/Rig.hs +4/−3
• src/Data/Extensible/Match.hs +17/−7
• src/Data/Extensible/Plain.hs +5/−22
• src/Data/Extensible/Product.hs +45/−20
• src/Data/Extensible/Record.hs +51/−33
• src/Data/Extensible/Sum.hs +28/−10
• src/Data/Extensible/Union.hs +6/−2

@@ -1,10 +1,55 @@-language: haskell
+# NB: don't set `language: haskell` here
 
+# See also https://github.com/hvr/multi-ghc-travis for more information
+
+# The following lines enable several GHC versions and/or HP versions
+# to be tested; often it's enough to test only against the last
+# release of a major GHC version. Setting HPVER implictly sets
+# GHCVER. Omit lines with versions you don't need/want testing for.
 env:
-  - GHCVER=7.8.4
+ - CABALVER=1.18 GHCVER=7.8.4
+ - CABALVER=1.22 GHCVER=7.10.1
 
+# Note: the distinction between `before_install` and `install` is not
+#       important.
 before_install:
-  - sudo add-apt-repository -y ppa:hvr/ghc
-  - sudo apt-get update
-  - sudo apt-get install -y -qq cabal-install-1.22 ghc-$GHCVER
-  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH
+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
+ - travis_retry sudo apt-get update
+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+
+install:
+ - cabal --version
+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - travis_retry cabal update
+ - cabal install --only-dependencies --enable-tests --enable-benchmarks
+
+# Here starts the actual work to be performed for the package under
+# test; any command which exits with a non-zero exit code causes the
+# build to fail.
+script:
+ - if [ -f configure.ac ]; then autoreconf -i; fi
+ # -v2 provides useful information for debugging
+ - cabal configure --enable-tests --enable-benchmarks -v2
+
+ # this builds all libraries and executables
+ # (including tests/benchmarks)
+ - cabal build
+
+ - cabal test
+ - cabal check
+
+ # tests that a source-distribution can be generated
+ - cabal sdist
+
+ # check that the generated source-distribution can be built & installed
+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
+   cd dist/;
+   if [ -f "$SRC_TGZ" ]; then
+      cabal install --force-reinstalls "$SRC_TGZ";
+   else
+      echo "expected '$SRC_TGZ' not found";
+      exit 1;
+   fi
+
+# EOF

@@ -1,3 +1,16 @@+0.3.3+-----------------------------------------------------+* Renamed `sectorAt`, `sector`, `sectorAssoc` to `pieceAt`, `piece`, `pieceAssoc`, respectively+* `picked` is now subsumed by `piece`+    * `mkField` yields more generalized optics+* Renamed `UnionAt` to `EmbedAt`+* Removed `clause`; Use `piece . _Match`+* Removed `record`; Use `piece . _K0`+* Added `htraverseWithIndex`+* Renamed `ord` to `mkMembership`+* Fixed the `Show` instance of `:|`+* Added `Variant`+ 0.3.2 ----------------------------------------------------- * Added `Associate` class and combinators around it

@@ -5,7 +5,8 @@  mkField "name weight price description featured quantity" -type Stock c = Record '["name" :> String+type Stock c = Record '[+    "name" :> String   , "weight" :> Float   , "price" :> c   , "featured" :> Bool@@ -21,7 +22,7 @@   <: Field 20   <: Nil --- Use shrink to permute elements+-- Use shrinkAssoc to permute elements s1 :: Num c => Stock c s1 = shrinkAssoc    $ name @= "HHP-150"

@@ -1,5 +1,5 @@ name:                extensible-version:             0.3.2+version:             0.3.3 synopsis:            Extensible, efficient, lens-friendly data types homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues@@ -29,6 +29,7 @@ library   exposed-modules:     Data.Extensible+    Data.Extensible.Class     Data.Extensible.Dictionary     Data.Extensible.Inclusion     Data.Extensible.Internal@@ -50,7 +51,7 @@     , FlexibleInstances     , PolyKinds     , CPP-  build-depends:       base >= 4.7 && <5, template-haskell, binary < 1, constraints+  build-depends:       base >= 4.7 && <5, template-haskell, constraints, profunctors   hs-source-dirs:      src-  ghc-options: -Wall -O2+  ghc-options: -Wall   default-language:    Haskell2010

@@ -23,7 +23,8 @@ ----------------------------------------------------------------------------- module Data.Extensible (   -- * Reexport-  module Data.Extensible.Dictionary+  module Data.Extensible.Class+  , module Data.Extensible.Dictionary   , module Data.Extensible.Inclusion   , module Data.Extensible.Match   , module Data.Extensible.Plain@@ -33,14 +34,13 @@   , Comp(..)   , comp   ) where++import Data.Extensible.Class+import Data.Extensible.Dictionary import Data.Extensible.Inclusion+import Data.Extensible.Internal.Rig import Data.Extensible.Match import Data.Extensible.Plain import Data.Extensible.Product-import Data.Extensible.Sum import Data.Extensible.Record-import Data.Extensible.Internal.Rig-import Data.Extensible.Dictionary----------------------------------------------------------------+import Data.Extensible.Sum

@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Data.Extensible.Class (+  -- * Class+   Extensible(..)+  , piece+  , pieceAssoc+  -- * Membership+  , Membership+  , mkMembership+  -- * Member+  , Member(..)+  , remember+  , (∈)()+  , FindType+  -- * Association+  , Assoc(..)+  , Associate(..)+  , FindAssoc+  -- * Sugar+  , Elaborate+  , Elaborated(..)+  ) where+import Data.Extensible.Internal++-- | This class allows us to use 'pieceAt' for both sums and products.+class Extensible f p q (t :: (k -> *) -> [k] -> *) where+  pieceAt :: Membership xs x -> p (h x) (f (h x)) -> q (t h xs) (f (t h xs))++-- | Accessor for an element.+piece :: (x ∈ xs, Extensible f p q t) => p (h x) (f (h x)) -> q (t h xs) (f (t h xs))+piece = pieceAt membership+{-# INLINE piece #-}++-- | Like 'piece', but reckon membership from its key.+pieceAssoc :: (Associate k v xs, Extensible f p q t) => p (h (k ':> v)) (f (h (k ':> v))) -> q (t h xs) (f (t h xs))+pieceAssoc = pieceAt association+{-# INLINE pieceAssoc #-}

@@ -10,17 +10,18 @@ -- Stability   :  experimental -- Portability :  non-portable ----- Reifying some classes to make instances for (':*') and (':|')+-- Reifying classes to make instances for (':*') and (':|') ----------------------------------------------------------------------- module Data.Extensible.Dictionary where import Data.Monoid+import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum import Data.Extensible.Internal import Data.Extensible.Internal.Rig-import qualified Data.Binary as B import Data.Constraint +-- | Reify a collection of dictionaries, as you wish. library :: forall c xs. Forall c xs => Comp Dict c :* xs library = htabulateFor (Proxy :: Proxy c) $ const (Comp Dict) {-# INLINE library #-}@@ -49,24 +50,22 @@   mappend xs ys = hzipWith3 (\(Comp Dict) -> mappend) (library :: Comp Dict (Instance1 Monoid h) :* xs) xs ys   {-# INLINE mappend #-} -instance WrapForall B.Binary h xs => B.Binary (h :* xs) where-  get = hgenerateFor (Proxy :: Proxy (Instance1 B.Binary h)) (const B.get)-  put = flip appEndo (return ()) . hfoldMap getConst' . hzipWith (\(Comp Dict) x -> Const' $ Endo $ (B.put x >>)) (library :: Comp Dict (Instance1 B.Binary h) :* xs)- instance WrapForall Show h xs => Show (h :| xs) where-  showsPrec d (UnionAt pos h) = showParen (d > 10) $ showString "embed "-    . views (sectorAt pos) (\(Comp Dict) -> showsPrec 11 h) (library :: Comp Dict (Instance1 Show h) :* xs)+  showsPrec d (EmbedAt i h) = showParen (d > 10) $ showString "EmbedAt "+    . showsPrec 11 i+    . showString " "+    . views (pieceAt i) (\(Comp Dict) -> showsPrec 11 h) (library :: Comp Dict (Instance1 Show h) :* xs)  instance WrapForall Eq h xs => Eq (h :| xs) where-  UnionAt p g == UnionAt q h = case compareMembership p q of+  EmbedAt p g == EmbedAt q h = case compareMembership p q of     Left _ -> False-    Right Refl -> views (sectorAt p) (\(Comp Dict) -> g == h) (library :: Comp Dict (Instance1 Eq h) :* xs)+    Right Refl -> views (pieceAt p) (\(Comp Dict) -> g == h) (library :: Comp Dict (Instance1 Eq h) :* xs)   {-# INLINE (==) #-}  instance (Eq (h :| xs), WrapForall Ord h xs) => Ord (h :| xs) where-  UnionAt p g `compare` UnionAt q h = case compareMembership p q of+  EmbedAt p g `compare` EmbedAt q h = case compareMembership p q of     Left x -> x-    Right Refl -> views (sectorAt p) (\(Comp Dict) -> compare g h) (library :: Comp Dict (Instance1 Ord h) :* xs)+    Right Refl -> views (pieceAt p) (\(Comp Dict) -> compare g h) (library :: Comp Dict (Instance1 Ord h) :* xs)   {-# INLINE compare #-}  -- | Forall upon a wrapper

@@ -12,25 +12,13 @@ -- ------------------------------------------------------------------------ module Data.Extensible.Inclusion (-  -- * Membership-    Membership-  , runMembership-  , (∈)()-  , Member(..)-  , remember-  , Expecting-  , Missing-  , Ambiguous-  , ord-  , Assoc(..)-  , Associate(..)   -- * Inclusion-  , (⊆)()+   (⊆)()   , Include   , inclusion   , shrink   , spread-  -- * Dictionary-like+  -- * Key-value   , IncludeAssoc   , Associated   , inclusionAssoc@@ -45,6 +33,7 @@   , mapNullable   ) where +import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum import Data.Extensible.Internal@@ -60,22 +49,23 @@ -- | Reify the inclusion of type level sets. inclusion :: forall xs ys. Include ys xs => Membership ys :* xs inclusion = htabulateFor (Proxy :: Proxy (Member ys)) (const membership)+{-# INLINABLE inclusion #-}  -- | /O(m log n)/ Select some elements. shrink :: (xs ⊆ ys) => h :* ys -> h :* xs-shrink h = hmap (`hlookup` h) inclusion+shrink h = hmap (hindex h) inclusion {-# INLINE shrink #-}  -- | /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+spread (EmbedAt i h) = views (pieceAt i) EmbedAt inclusion h {-# INLINE spread #-}  -- | The inverse of 'inclusion'. coinclusion :: (Include ys xs, Generate ys) => Nullable (Membership xs) :* ys coinclusion = flip appEndo (htabulate (const Null))   $ hfoldMap getConst'-  $ hmapWithIndex (\src dst -> Const' $ Endo $ sectorAt dst `over` const (Eine src))+  $ hmapWithIndex (\src dst -> Const' $ Endo $ pieceAt dst `over` const (Eine src))   $ inclusion  -- | Extend a product and fill missing fields by 'Null'.@@ -85,7 +75,7 @@  -- | Narrow the range of the sum, if possible. retrench :: (Generate ys, xs ⊆ ys) => h :| ys -> Nullable ((:|) h) xs-retrench (UnionAt pos h) = views (sectorAt pos) (mapNullable (`UnionAt`h)) coinclusion+retrench (EmbedAt i h) = views (pieceAt i) (mapNullable (`EmbedAt`h)) coinclusion {-# INLINE retrench #-}  ------------------------------------------------------------------@@ -95,20 +85,22 @@  instance Associate k v xs => Associated xs (k ':> v) where   getAssociation = association+  {-# INLINE getAssociation #-} --- | Similar to 'Include', but works nicely for key-value pairs.-type IncludeAssoc ys xs = Forall (Associated ys) xs+-- | Similar to 'Include', but this focuses on keys.+type IncludeAssoc ys = Forall (Associated ys)  -- | 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)+{-# INLINABLE inclusionAssoc #-}  -- | /O(m log n)/ Select some elements. shrinkAssoc :: (IncludeAssoc ys xs) => h :* ys -> h :* xs-shrinkAssoc h = hmap (`hlookup` h) inclusionAssoc+shrinkAssoc h = hmap (hindex 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+spreadAssoc (EmbedAt i h) = views (pieceAt i) EmbedAt inclusionAssoc h {-# INLINE spreadAssoc #-}

@@ -15,33 +15,36 @@ -- -- A bunch of combinators that contains magic -------------------------------------------------------------------------module Data.Extensible.Internal (Membership+module Data.Extensible.Internal (+  -- * Membership+  Membership   , getMemberId+  , mkMembership   , runMembership   , compareMembership-  , ord+  -- * Member class+  , Member(..)+  , remember+  , (∈)()+  , FindType+  -- * Association+  , Assoc(..)+  , Associate(..)+  , FindAssoc+  -- * Sugar+  , Elaborate+  , Elaborated(..)+  -- * Tree navigation   , NavHere(..)   , navigate   , here   , navNext   , navL   , navR-  , (:*)(..)-  , Member(..)-  , remember-  , (∈)()+  -- * Miscellaneous   , Nat(..)-  , ToInt(..)-  , Lookup-  , ListIndex-  , Assoc(..)-  , AssocKeys-  , Associate(..)-  , LookupTree(..)+  , KnownPosition(..)   , Succ-  , MapSucc-  , Pred-  , Div2   , Half   , Head   , Tail@@ -51,10 +54,6 @@   , Map   , Merge   , Concat-  , Check-  , Expecting-  , Missing-  , Ambiguous   , module Data.Type.Equality   , module Data.Proxy   ) where@@ -70,10 +69,9 @@ import Language.Haskell.TH hiding (Pred) import Data.Bits - -- | Generates a 'Membership' that corresponds to the given ordinal (0-origin).-ord :: Int -> Q Exp-ord n = do+mkMembership :: Int -> Q Exp+mkMembership n = do   let names = map mkName $ take (n + 1) $ concatMap (flip replicateM ['a'..'z']) [1..]   let rest = mkName "any"   let cons x xs = PromotedConsT `AppT` x `AppT` xs@@ -89,71 +87,46 @@  -- | Remember that @Member xs x@ from 'Membership'. remember :: forall xs x r. Membership xs x -> (Member xs x => r) -> r-remember pos r = unsafeCoerce (Remembrance r :: Remembrance xs x r) pos+remember i r = unsafeCoerce (Remembrance r :: Remembrance xs x r) i {-# INLINE remember #-} --- | 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)--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+class Member xs x where+  membership :: Membership xs x -type family Div2 (n :: Nat) :: Nat where-  Div2 ('SDNat n) = n-  Div2 ('DNat n) = n-  Div2 'Zero = 'Zero+instance (Elaborate x (FindType x xs) ~ 'Expecting pos, KnownPosition pos) => Member xs x where+  membership = Membership (theInt (Proxy :: Proxy pos))+  {-# INLINE membership #-}  -- | 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 '[] = '[]+infix 0 :>  -- | @'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 :* '[]-  Tree :: !(h x)-    -> h :* Half xs-    -> h :* Half (Tail xs)-    -> h :* (x ': xs)--deriving instance Typeable (:*)+instance (Elaborate k (FindAssoc k xs) ~ 'Expecting (n ':> v), KnownPosition n) => Associate k v xs where+  association = Membership (theInt (Proxy :: Proxy n)) -class LookupTree (n :: Nat) (xs :: [k]) x | n xs -> x where-  lookupTree :: Functor f => proxy n-    -> (h x -> f (h x))-    -> h :* xs -> f (h :* xs)+data Elaborated k v = Expecting v | Missing k | Duplicate k -instance LookupTree 'Zero (x ': xs) x where-  lookupTree _ f (Tree h a b) = fmap (\h' -> Tree h' a b) (f h)-  {-# INLINE lookupTree #-}+type family Elaborate (key :: k) (xs :: [v]) :: Elaborated k v where+  Elaborate k '[] = 'Missing k+  Elaborate k '[x] = 'Expecting x+  Elaborate k xs = 'Duplicate k -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 #-}+type family FindAssoc (key :: k) (xs :: [Assoc k v]) where+  FindAssoc k ((k ':> v) ': xs) = ('Zero ':> v) ': MapSuccKey (FindAssoc k xs)+  FindAssoc k ((k' ':> v) ': xs) = MapSuccKey (FindAssoc k xs)+  FindAssoc k '[] = '[] -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 #-}+type family MapSuccKey (xs :: [Assoc Nat v]) :: [Assoc Nat v] where+  MapSuccKey '[] = '[]+  MapSuccKey ((k ':> x) ': xs) = (Succ k ':> x) ': MapSuccKey xs  instance Show (Membership xs x) where-  show (Membership n) = "$(ord " ++ show n ++ ")"+  show (Membership n) = "$(mkMembership " ++ show n ++ ")"  instance Eq (Membership xs x) where   _ == _ = True@@ -217,33 +190,11 @@ type family Head (xs :: [k]) :: k where   Head (x ': xs) = x -class Member xs x where-  membership :: Membership xs x---- | A type sugar to make type error more readable.-data Expecting a---- | A type sugar to make type error more readable.-data Missing a---- | A type sugar to make type error more readable.-data Ambiguous a---- | Elaborate the result of 'Lookup'-type family Check x xs where-  Check x '[n] = Expecting n-  Check x '[] = Missing x-  Check x xs = Ambiguous x--instance (Check x (Lookup x xs) ~ Expecting one, ToInt one) => Member xs x where-  membership = Membership (theInt (Proxy :: Proxy one))-  {-# INLINE membership #-}---- | Lookup types-type family Lookup (x :: k) (xs :: [k]) :: [Nat] where-  Lookup x (x ': xs) = 'Zero ': Lookup x xs-  Lookup x (y ': ys) = MapSucc (Lookup x ys)-  Lookup x '[] = '[]+-- | FindType types+type family FindType (x :: k) (xs :: [k]) :: [Nat] where+  FindType x (x ': xs) = 'Zero ': FindType x xs+  FindType x (y ': ys) = MapSucc (FindType x ys)+  FindType x '[] = '[]  -- | Interleaved list type family Half (xs :: [k]) :: [k] where@@ -260,18 +211,18 @@ data Nat = Zero | DNat Nat | SDNat Nat  -- | Converts type naturals into 'Word'.-class ToInt n where+class KnownPosition n where   theInt :: proxy n -> Word -instance ToInt 'Zero where+instance KnownPosition 'Zero where   theInt _ = 0   {-# INLINE theInt #-} -instance ToInt n => ToInt ('DNat n) where+instance KnownPosition n => KnownPosition ('DNat n) where   theInt _ = theInt (Proxy :: Proxy n) `unsafeShiftL` 1   {-# INLINE theInt #-} -instance ToInt n => ToInt ('SDNat n) where+instance KnownPosition n => KnownPosition ('SDNat n) where   theInt _ = (theInt (Proxy :: Proxy n) `unsafeShiftL` 1) + 1   {-# INLINE theInt #-} 

@@ -20,6 +20,7 @@ import Data.Foldable (Foldable) import Data.Traversable (Traversable) #endif+import Data.Profunctor  -- | A type synonym for lenses type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s@@ -37,6 +38,9 @@ -- | Just a value. newtype K0 a = K0 { getK0 :: a } deriving (Eq, Ord, Read, Typeable, Functor, Foldable, Traversable) +_K0 :: (Functor f, Profunctor p) => p a (f b) -> p (K0 a) (f (K0 b))+_K0 = dimap getK0 (fmap K0)+ instance Applicative K0 where   pure = K0   K0 f <*> K0 a = K0 (f a)@@ -55,9 +59,6 @@  -- | Poly-kinded Const newtype Const' a x = Const' { getConst' :: a } deriving Show---- | Turn a wrapper type into one clause that returns @a@.-newtype Match h a x = Match { runMatch :: h x -> a } deriving Typeable  newtype Comp f g a = Comp { getComp :: f (g a) } 

@@ -11,20 +11,24 @@ -- Pattern matching ------------------------------------------------------------------------ module Data.Extensible.Match (-  Match(..)-  , clause+  matchWith+  , Match(..)+  , _Match   , match   , mapMatch   , caseOf) where -import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum+import Data.Profunctor+import Data.Typeable --- | A lens for a specific clause.-clause :: (x ∈ xs) => Lens' (Match h a :* xs) (h x -> a)-clause f = sector (fmap Match . f . runMatch)+-- | Retrieve the contents so that they matches and pass both to the given function.+matchWith :: (forall x. f x -> g x -> r) -> f :* xs -> g :| xs -> r+matchWith f p = \(EmbedAt i h) -> views (pieceAt i) f p h+{-# INLINE matchWith #-}  -- | Applies a function to the result of 'Match'. mapMatch :: (a -> b) -> Match h a x -> Match h b x@@ -33,7 +37,7 @@  -- | /O(log n)/ Perform pattern matching. match :: Match h a :* xs -> h :| xs -> a-match p = \(UnionAt pos h) -> views (sectorAt pos) runMatch p h+match = matchWith runMatch {-# INLINE match #-}  -- | Flipped `match`@@ -41,3 +45,9 @@ caseOf = flip match {-# INLINE caseOf #-} infix 0 `caseOf`++-- | Turn a wrapper type into one clause that returns @a@.+newtype Match h a x = Match { runMatch :: h x -> a } deriving Typeable++_Match :: (Profunctor p, Functor f) => p (g x -> a) (f (h y -> b)) -> p (Match g a x) (f (Match h b y))+_Match = dimap runMatch (fmap Match)

@@ -12,21 +12,20 @@ ------------------------------------------------------------------------ module Data.Extensible.Plain (   K0(..)+  , _K0   , AllOf   , OneOf   , (<%)   , pluck   , bury   , (<%|)-  , record-  , recordAt-  , (<?%)   , accessing   , decFields   , decFieldsDeriving-  )where+  ) where import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import Data.Extensible.Class import Data.Extensible.Product import Data.Extensible.Sum import Unsafe.Coerce@@ -48,7 +47,7 @@  -- | Extract a plain value. pluck :: (x ∈ xs) => AllOf xs -> x-pluck = views sector getK0+pluck = views piece getK0 {-# INLINE pluck #-}  -- | Embed a plain value.@@ -61,25 +60,9 @@ (<%|) = unsafeCoerce (<:|) infixr 1 <%| --- | /O(log n)/ A lens for a plain value in a product.-record :: (x ∈ xs, Functor f) => (x -> f x) -> (AllOf xs -> f (AllOf xs))-record f = sector $ unsafeCoerce f `asTypeOf` (fmap K0 . f . getK0)-{-# INLINE record #-}---- | /O(log n)/ A lens for a plain value in a product.-recordAt :: (Functor f) => Membership xs x -> (x -> f x) -> (AllOf xs -> f (AllOf xs))-recordAt pos f = sectorAt pos $ unsafeCoerce f `asTypeOf` (fmap K0 . f . getK0)-{-# INLINE recordAt #-}---- | Prepend a clause for a plain value.-(<?%) :: (x -> a) -> Match K0 a :* xs -> Match K0 a :* (x ': xs)-(<?%) = unsafeCoerce (<:*)-{-# INLINE (<?%) #-}-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)+accessing c f = piece (_K0 (fmap c . f . coerce)) {-# INLINE accessing #-}  -- | Generate newtype wrappers and lenses from type synonyms.

@@ -28,15 +28,15 @@   , hzipWith3   , hfoldMap   , htraverse+  , htraverseWithIndex   , hsequence   , hcollect   , hdistribute   -- * Lookup   , hlookup   , hindex-  , sector-  , sectorAssoc   , sectorAt+  , sector   -- * Generation   , Generate(..)   , htabulate@@ -50,14 +50,25 @@ import Control.Applicative #endif import Data.Monoid+import Data.Typeable+import Data.Extensible.Class +-- | The type of extensible products.+data (h :: k -> *) :* (s :: [k]) where+  Nil :: h :* '[]+  Tree :: !(h x)+    -> h :* Half xs+    -> h :* Half (Tail xs)+    -> h :* (x ': xs)++deriving instance Typeable (:*)+ -- | /O(1)/ Extract the head element. hhead :: h :* (x ': xs) -> h x hhead (Tree a _ _) = a {-# INLINE hhead #-}  -- | /O(n)/ Extract the tail of the product.--- FIXME: unsafeCoerce htail :: h :* (x ': xs) -> h :* xs htail (Tree _ a@(Tree h _ _) b) = unsafeCoerce (Tree h) b (htail a) htail (Tree _ Nil _) = unsafeCoerce Nil@@ -137,7 +148,7 @@  -- | The dual of 'htraverse' hcollect :: (Functor f, Generate xs) => (a -> h :* xs) -> f a -> Comp f h :* xs-hcollect f m = htabulate $ \pos -> Comp $ fmap (hlookup pos . f) m+hcollect f m = htabulate $ \i -> Comp $ fmap (hlookup i . f) m {-# INLINABLE hcollect #-}  -- | The dual of 'hsequence'@@ -147,7 +158,7 @@  -- | /O(log n)/ Pick up an elemtnt. hlookup :: Membership xs x -> h :* xs -> h x-hlookup = view . sectorAt+hlookup = view . pieceAt {-# INLINABLE hlookup #-}  -- | Flipped 'hlookup'@@ -155,7 +166,7 @@ hindex = flip hlookup {-# INLINE hindex #-} --- | 'hmap' with its indices.+-- | 'hmap' with 'Membership's. hmapWithIndex :: forall g h xs. (forall x. Membership xs x -> g x -> h x) -> g :* xs -> h :* xs hmapWithIndex f = go id where   go :: (forall x. Membership t x -> Membership xs x) -> g :* t -> h :* t@@ -163,30 +174,44 @@   go _ Nil = Nil {-# INLINE hmapWithIndex #-} --- | /O(log n)/ A lens for a specific element.-sector :: (x ∈ xs) => Lens' (h :* xs) (h x)-sector = sectorAt membership-{-# INLINE sector #-}+-- | 'htraverse' with 'Membership's.+htraverseWithIndex :: forall f g h xs. Applicative f+  => (forall x. Membership xs x -> g x -> f (h x)) -> g :* xs -> f (h :* xs)+htraverseWithIndex f = go id where+  go :: (forall x. Membership t x -> Membership xs x) -> g :* t -> f (h :* t)+  go k (Tree g a b) = Tree <$> f (k here) g <*> go (k . navL) a <*> go (k . navR) b+  go _ Nil = pure Nil+{-# INLINE htraverseWithIndex #-} --- | /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 #-}+instance Functor f => Extensible f (->) (->) (:*) where+  -- | /O(log n)/ A lens for a value in a known position.+  pieceAt = pieceAt_+  {-# INLINE pieceAt #-} --- | /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)-sectorAt pos f = flip go pos where+pieceAt_ :: forall (xs :: [k]) (x :: k) (h :: k -> *) (f :: * -> *). Functor f+  => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs)+pieceAt_ i f = flip go i where   go :: forall t. h :* t -> Membership t x -> f (h :* t)   go (Tree h a b) = navigate     (\Here -> fmap (\h' -> Tree h' a b) (f h))     (fmap (\a' -> Tree h a' b) . go a)     (fmap (\b' -> Tree h a b') . go b)   go Nil = error "Impossible"-{-# INLINE sectorAt #-}+{-# INLINE pieceAt_ #-} +{-# DEPRECATED sectorAt "Use pieceAt" #-}+-- | The legacy name for 'pieceAt'+sectorAt :: Functor f => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs)+sectorAt = pieceAt++{-# DEPRECATED sector "Use piece" #-}+-- | The legacy name for 'piece'+sector :: (Functor f, x ∈ xs) => (h x -> f (h x)) -> h :* xs -> f (h :* xs)+sector = piece+ -- | Given a function that maps types to values, we can "collect" entities all you want. class Generate (xs :: [k]) where-  -- | /O(n)/ htabulates a product with the given function.+  -- | /O(n)/ Generate a product with the given function.   hgenerate :: Applicative f => (forall x. Membership xs x -> f (h x)) -> f (h :* xs)  instance Generate '[] where@@ -210,7 +235,7 @@  -- | Guarantees the all elements satisfies the predicate. class Forall c (xs :: [k]) where-  -- | /O(n)/ Analogous to 'htabulate', but it also supplies a context @c x@ for every elements in @xs@.+  -- | /O(n)/ Analogous to 'hgenerate', but it also supplies a context @c x@ for every elements in @xs@.   hgenerateFor :: Applicative f => proxy c -> (forall x. c x => Membership xs x -> f (h x)) -> f (h :* xs)  instance Forall c '[] where

@@ -9,26 +9,31 @@ -- Stability   :  experimental -- Portability :  non-portable ----- Flexible records with well-typed fields.+-- Flexible records and variants -- Example: <https://github.com/fumieval/extensible/blob/master/examples/records.hs> ------------------------------------------------------------------------ module Data.Extensible.Record (-   module Data.Extensible.Inclusion-  , Record-  , (<:)-  , (<:*)-  , (:*)(Nil)+   module Data.Extensible.Class+  , module Data.Extensible.Inclusion   , (@=)   , (<@=>)   , mkField   , Field(..)   , getField-  , FieldLens+  , FieldOptic   , FieldName+  , fieldOptic+  -- * Records and variants+  , Record+  , (<:)+  , (:*)(Nil)+  , Variant   -- * Internal-  , Labelable(..)   , LabelPhantom+  , Labelling   ) where+import Data.Extensible.Class+import Data.Extensible.Sum import Data.Extensible.Product import Data.Extensible.Internal import Data.Extensible.Internal.Rig@@ -37,6 +42,8 @@ import Data.Extensible.Inclusion import Data.Extensible.Dictionary () import Control.Monad+import Data.Profunctor+import Data.Constraint  -- | The type of fields. data Field kv where@@ -45,43 +52,57 @@ -- | Get a value of a field. getField :: Field (k ':> v) -> v getField (Field v) = v+{-# INLINE getField #-}  -- | The type of records which contain several fields. type Record = (:*) Field +-- | The dual of 'Record'+type Variant = (:|) Field+ -- | Shows in @field \@= value@ style instead of the derived one. 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@.+-- | @FieldOptic s@ is a type of optics that points a field/constructor named @s@. --+-- The yielding fields can be+-- <http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Lens>es+-- for 'Record's and+-- <http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Prism Prism>s+-- for 'Variant's.+-- -- @--- 'FieldLens' "foo" = Associate "foo" a xs => Lens' ('Record' xs) a+-- 'FieldOptic' "foo" = Associate "foo" a xs => Lens' ('Record' xs) a+-- 'FieldOptic' "foo" = Associate "foo" a xs => Prism' ('Variant' xs) a -- @ ---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)+type FieldOptic k = forall f p q t xs v. (Functor f+  , Profunctor p+  , Extensible f p q t+  , Associate k v xs+  , Labelling k p)+  => p v (f v) -> q (t Field xs) (f (t Field 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 k = forall v. LabelPhantom k v (Proxy v)   -> Record '[k ':> v] -> Proxy (Record '[k ':> v]) +type family Labelling s p :: Constraint where+  Labelling s (LabelPhantom t) = s ~ t+  Labelling s p = ()+ -- | A ghostly type which spells the field name data LabelPhantom s a b --- | An internal class to characterize 'FieldLens'-class Labelable s p where-  unlabel :: proxy s -> p a b -> a -> b--instance Labelable s (->) where-  unlabel _ = id-  {-# INLINE unlabel #-}+instance Profunctor (LabelPhantom s) where+  dimap _ _ _ = error "Impossible" -instance (s ~ t) => Labelable s (LabelPhantom t) where-  unlabel _ = error "Impossible"+instance Extensible f (LabelPhantom s) q t where+  pieceAt _ _ = error "Impossible"  -- | Annotate a value by the field name. (@=) :: FieldName k -> v -> Field (k ':> v)@@ -95,27 +116,24 @@ {-# INLINE (<@=>) #-} infix 1 <@=> -type Assoc_ a b = a ':> b+-- | Generate a field optic from the given name.+fieldOptic :: forall proxy k. proxy k -> FieldOptic k+fieldOptic _ = pieceAssoc . dimap getField (fmap (Field :: v -> Field (k ':> v)))+{-# INLINE fieldOptic #-} --- | Generate a field.+-- | Generate fields using 'fieldOptic'. -- @'mkField' "foo bar"@ defines: -- -- @--- foo :: FieldLens "foo"--- foo :: FieldLens "bar"+-- foo :: FieldOptic "foo"+-- bar :: FieldOptic "bar" -- @ ----- The yielding field is a <http://hackage.haskell.org/package/lens/docs/Control-Lens-Lens.html#t:Lens Lens>. mkField :: String -> DecsQ mkField str = fmap concat $ forM (words str) $ \s -> do-  f <- newName "f"   let st = litT (strTyLit s)-  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 [sigD (mkName s) $ conT ''FieldLens `appT` st-    , funD (mkName s) [clause [varP f] (normalB $ varE 'sectorAssoc `appE` wf) []]+  sequence [sigD (mkName s) $ conT ''FieldOptic `appT` st+    , valD (varP (mkName s)) (normalB $ varE 'fieldOptic `appE` lbl) []     , return $ PragmaD $ InlineP (mkName s) Inline FunLike AllPhases     ]

@@ -1,6 +1,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Sum@@ -22,6 +24,7 @@   , exhaust   , picked   , embedAssoc+  , pattern UnionAt   ) where  import Data.Extensible.Internal@@ -29,37 +32,44 @@ import Control.Applicative #endif import Data.Typeable+import Data.Extensible.Class+import Data.Profunctor  -- | The extensible sum type data (h :: k -> *) :| (s :: [k]) where-  UnionAt :: !(Membership xs x) -> h x -> h :| xs+  EmbedAt :: !(Membership xs x) -> h x -> h :| xs deriving instance Typeable (:|) +{-# DEPRECATED UnionAt "This has renamed to EmbedAt" #-}+pattern UnionAt a b = EmbedAt a b+ -- | Change the wrapper. hoist :: (forall x. g x -> h x) -> g :| xs -> h :| xs-hoist f (UnionAt pos h) = UnionAt pos (f h)+hoist f (EmbedAt p h) = EmbedAt p (f h) {-# INLINE hoist #-}  -- | /O(1)/ lift a value. embed :: (x ∈ xs) => h x -> h :| xs-embed = UnionAt membership+embed = EmbedAt membership {-# INLINE embed #-} +-- | Try to extract something you want. strike :: forall h x xs. (x ∈ xs) => h :| xs -> Maybe (h x) strike = strikeAt membership {-# INLINE strike #-} +-- | Try to extract something you want. strikeAt :: forall h x xs. Membership xs x -> h :| xs -> Maybe (h x)-strikeAt q (UnionAt p h) = case compareMembership p q of+strikeAt q (EmbedAt p h) = case compareMembership p q of   Right Refl -> Just h   _ -> Nothing {-# INLINE strikeAt #-}  -- | /O(1)/ Naive pattern match (<:|) :: (h x -> r) -> (h :| xs -> r) -> h :| (x ': xs) -> r-(<:|) r c = \(UnionAt pos h) -> runMembership pos+(<:|) r c = \(EmbedAt i h) -> runMembership i   (\Refl -> r h)-  (\pos' -> c (UnionAt pos' h))+  (\j -> c (EmbedAt j h)) infixr 1 <:| {-# INLINE (<:|) #-} @@ -67,12 +77,20 @@ exhaust :: h :| '[] -> r exhaust _ = error "Impossible" +-- | Embed a value, but focuses on its key.+embedAssoc :: Associate k a xs => h (k ':> a) -> h :| xs+embedAssoc = EmbedAt association+{-# INLINE embedAssoc #-}++{-# DEPRECATED picked "Use piece instead" #-} -- | A traversal that tries to point a specific element. picked :: forall f h x xs. (x ∈ xs, Applicative f) => (h x -> f (h x)) -> h :| xs -> f (h :| xs)-picked f u@(UnionAt pos h) = case compareMembership (membership :: Membership xs x) pos of-  Right Refl -> fmap (UnionAt pos) (f h)+picked f u@(EmbedAt i h) = case compareMembership (membership :: Membership xs x) i of+  Right Refl -> fmap (EmbedAt i) (f h)   _ -> pure u {-# INLINE picked #-} -embedAssoc :: Associate k a xs => h (k ':> a) -> h :| xs-embedAssoc = UnionAt association+instance (Applicative f, Choice p) => Extensible f p p (:|) where+  pieceAt m p = dimap (\t@(EmbedAt i h) -> case compareMembership i m of+    Right Refl -> Right h+    Left _ -> Left t) (either pure (fmap (EmbedAt m))) (right' p)

@@ -15,6 +15,7 @@  import Data.Extensible.Internal import Data.Extensible.Internal.Rig+import Data.Extensible.Class import Data.Extensible.Sum import Data.Extensible.Product import Data.Typeable@@ -25,7 +26,8 @@ newtype Union xs a = Union { getUnion :: K1 a :| xs }  reunion :: Gondola m :* xs -> Union xs a -> m a-reunion gs (Union (UnionAt pos (K1 f))) = views (sectorAt pos) runGondola gs f+reunion gs = \(Union (EmbedAt i (K1 f))) -> views (pieceAt i) runGondola gs f+{-# INLINE reunion #-}  -- | Transformation between effects newtype Gondola f g = Gondola { runGondola :: forall a. g a -> f a }@@ -33,8 +35,10 @@ -- | Add a new transformation. rung :: (forall x. f x -> g x) -> Gondola g :* fs -> Gondola g :* (f ': fs) rung f = (<:) (Gondola f)+{-# INLINE rung #-}+ infixr 0 `rung`  runGondolas :: (x ∈ xs) => Gondola f :* xs -> x a -> f a-runGondolas = views sector runGondola+runGondolas = views piece runGondola {-# INLINE runGondolas #-}