packages feed

extensible 0.2.6 → 0.2.7

raw patch · 13 files changed

+156/−61 lines, 13 files

Files

CHANGELOG.md view
@@ -1,3 +1,9 @@+0.2.7+-----------------------------------------------------+* Added `accessing`+* Added `decFields` and `decFieldsDeriving`+* Renamed `Position` to `Membership`+* 0.2.6 ----------------------------------------------------- * Right-associated `(++)`
+ examples/records-plain.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell, DataKinds, TypeOperators, TypeFamilies, FlexibleContexts #-}++import Data.Extensible+import Control.Lens+decFieldsDeriving [''Show, ''Eq, ''Ord] [d|+  type Name = String+  type Weight = Float+  type Price = Int+  type Description = String+  type Featured = Bool+  type Quantity = Int+  |]++type Stock = AllOf '[Name, Weight, Price, Featured, Description, Quantity]++s0 :: Stock+s0 = Name "DA-192H"+  <% Weight 260+  <% Price 120+  <% Featured True+  <% Description "High-quality (24bit 192kHz), lightweight portable DAC"+  <% Quantity 20+  <% Nil++-- Use shrink to permute elements+s1 :: Stock+s1 = shrink+   $ Name "HHP-150"+  <% Featured False+  <% Description "Premium wooden headphone"+  <% Weight 150+  <% Price 330+  <% Quantity 55+  <% Nil++-- If Quantity is missing,+--    Couldn't match type ‘Missing Quantity’ with ‘Expecting one’+--+-- If there are duplicate Quantity,+--    Couldn't match type ‘Ambiguous Quantity’ with ‘Expecting one’++printSummary :: (Name ∈ s, Description ∈ s) => AllOf s -> IO ()+printSummary s = putStrLn $ view name s ++ ": " ++ view description s
extensible.cabal view
@@ -1,5 +1,5 @@ name:                extensible-version:             0.2.6+version:             0.2.7 synopsis:            Extensible, efficient, lens-friendly data types homepage:            https://github.com/fumieval/extensible bug-reports:         http://github.com/fumieval/extensible/issues
src/Data/Extensible.hs view
@@ -27,8 +27,8 @@   , module Data.Extensible.League   , module Data.Extensible.Match   , module Data.Extensible.Plain-  , module Data.Extensible.Product   , module Data.Extensible.Record+  , module Data.Extensible.Product   , module Data.Extensible.Sum   , module Data.Extensible.Union   ) where
src/Data/Extensible/Dictionary.hs view
@@ -41,7 +41,7 @@     . foldr (.) id     . getMerged     . hfoldMap getConst'-    . hzipWith (\(Match f) h -> Const' $ MergeList [f h 0 . showString " <:* "]) dictShow+    . hzipWith (\(Match f) h -> Const' $ MergeList [f h 0 . showString " <: "]) dictShow  instance WrapForall Eq h xs => Eq (h :* xs) where   xs == ys = getAll $ hfoldMap (All . getConst')@@ -64,13 +64,13 @@     . runMatch (hlookup pos dictShow) h 11  instance WrapForall Eq h xs => Eq (h :| xs) where-  UnionAt p g == UnionAt q h = case comparePosition p q of+  UnionAt p g == UnionAt q h = case compareMembership p q of     Left _ -> False     Right Refl -> unwrap2 (hlookup p dictEq) g h   {-# INLINE (==) #-}  instance (Eq (h :| xs), WrapForall Ord h xs) => Ord (h :| xs) where-  UnionAt p g `compare` UnionAt q h = case comparePosition p q of+  UnionAt p g `compare` UnionAt q h = case compareMembership p q of     Left x -> x     Right Refl -> unwrap2 (hlookup p dictOrd) g h   {-# INLINE compare #-}
src/Data/Extensible/Inclusion.hs view
@@ -12,8 +12,8 @@ ------------------------------------------------------------------------ module Data.Extensible.Inclusion (   -- * Membership-    Position-  , runPosition+    Membership+  , runMembership   , (∈)()   , Member(..)   , Expecting@@ -49,7 +49,7 @@ type Include ys = Forall (Member ys)  -- | Reify the inclusion of type level sets.-inclusion :: forall xs ys. Include ys xs => Position ys :* xs+inclusion :: forall xs ys. Include ys xs => Membership ys :* xs inclusion = generateFor (Proxy :: Proxy (Member ys)) (const membership)  -- | /O(m log n)/ Select some elements.@@ -57,7 +57,7 @@ shrink h = hmap (\pos -> hlookup pos h) inclusion {-# INLINE shrink #-} -subset :: (xs ⊆ ys, Functor f) => (h :* xs -> f (h :* xs)) -> h :* ys -> f (h :* ys)+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'@@ -69,7 +69,7 @@ {-# INLINE spread #-}  -- | The inverse of 'inclusion'.-coinclusion :: (Include ys xs, Generate ys) => Nullable (Position xs) :* ys+coinclusion :: (Include ys xs, Generate ys) => Nullable (Membership xs) :* ys coinclusion = flip appEndo (generate (const Null))   $ hfoldMap getConst'   $ htabulate (\src dst -> Const' $ Endo $ sectorAt dst `over` const (Eine src))
src/Data/Extensible/Internal.hs view
@@ -14,9 +14,9 @@ -- -- A bunch of combinators that contains magic -------------------------------------------------------------------------module Data.Extensible.Internal (Position-  , runPosition-  , comparePosition+module Data.Extensible.Internal (Membership+  , runMembership+  , compareMembership   , ord   , Nav(..)   , navigate@@ -54,66 +54,66 @@ import Data.Typeable import Language.Haskell.TH --- | Generates a 'Position' that corresponds to the given ordinal (0-origin).+-- | Generates a 'Membership' that corresponds to the given ordinal (0-origin). ord :: Int -> Q Exp ord 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   let t = foldr cons (VarT rest) (map VarT names)-  sigE (conE 'Position `appE` litE (IntegerL $ toInteger n))+  sigE (conE 'Membership `appE` litE (IntegerL $ toInteger n))     $ forallT (PlainTV rest : map PlainTV names) (pure [])-    $ conT ''Position `appT` pure t `appT` varT (names !! n)+    $ conT ''Membership `appT` pure t `appT` varT (names !! n)  -- | The position of @x@ in the type level set @xs@.-newtype Position (xs :: [k]) (x :: k) = Position Int deriving Typeable+newtype Membership (xs :: [k]) (x :: k) = Membership Int deriving Typeable -instance Show (Position xs x) where-  show (Position n) = "$(ord " ++ show n ++ ")"+instance Show (Membership xs x) where+  show (Membership n) = "$(ord " ++ show n ++ ")" -instance Eq (Position xs x) where+instance Eq (Membership xs x) where   _ == _ = True -instance Ord (Position xs x) where+instance Ord (Membership xs x) where   compare _ _ = EQ --- | Embodies a type equivalence to ensure that the 'Position' points the first element.-runPosition :: Position (y ': xs) x -> Either (x :~: y) (Position xs x)-runPosition (Position 0) = Left (unsafeCoerce Refl)-runPosition (Position n) = Right (Position (n - 1))-{-# INLINE runPosition #-}+-- | Embodies a type equivalence to ensure that the 'Membership' points the first element.+runMembership :: Membership (y ': xs) x -> Either (x :~: y) (Membership xs x)+runMembership (Membership 0) = Left (unsafeCoerce Refl)+runMembership (Membership n) = Right (Membership (n - 1))+{-# INLINE runMembership #-} -comparePosition :: Position xs x -> Position xs y -> Either Ordering (x :~: y)-comparePosition (Position m) (Position n) = case compare m n of+compareMembership :: Membership xs x -> Membership xs y -> Either Ordering (x :~: y)+compareMembership (Membership m) (Membership n) = case compare m n of   EQ -> Right (unsafeCoerce Refl)   x -> Left x-{-# INLINE comparePosition #-}+{-# INLINE compareMembership #-} -navigate :: Position xs x -> Nav xs x-navigate (Position 0) = unsafeCoerce Here-navigate (Position n) = let (m, r) = divMod (n - 1) 2 in case r of-  0 -> unsafeCoerce $ NavL $ Position m-  _ -> unsafeCoerce $ NavR $ Position m+navigate :: Membership xs x -> Nav xs x+navigate (Membership 0) = unsafeCoerce Here+navigate (Membership n) = let (m, r) = divMod (n - 1) 2 in case r of+  0 -> unsafeCoerce $ NavL $ Membership m+  _ -> unsafeCoerce $ NavR $ Membership m  data Nav xs x where   Here :: Nav (x ': xs) x-  NavL :: Position (Half xs) x -> Nav (e ': xs) x-  NavR :: Position (Half (Tail xs)) x -> Nav (e ': xs) x+  NavL :: Membership (Half xs) x -> Nav (e ': xs) x+  NavR :: Membership (Half (Tail xs)) x -> Nav (e ': xs) x -here :: Position (x ': xs) x-here = Position 0+here :: Membership (x ': xs) x+here = Membership 0 {-# INLINE here #-} -navNext :: Position xs y -> Position (x ': xs) y-navNext (Position n) = Position (n + 1)+navNext :: Membership xs y -> Membership (x ': xs) y+navNext (Membership n) = Membership (n + 1) {-# INLINE navNext #-} -navL :: Position (Half xs) y -> Position (x ': xs) y-navL (Position x) = Position (x * 2 + 1)+navL :: Membership (Half xs) y -> Membership (x ': xs) y+navL (Membership x) = Membership (x * 2 + 1) {-# INLINE navL #-} -navR :: Position (Half (Tail xs)) y -> Position (x ': xs) y-navR (Position x) = Position (x * 2 + 2)+navR :: Membership (Half (Tail xs)) y -> Membership (x ': xs) y+navR (Membership x) = Membership (x * 2 + 2) {-# INLINE navR #-}  -- | Unicode flipped alias for 'Member'@@ -121,7 +121,7 @@  -- | @Member x xs@ or @x ∈ xs@ indicates that @x@ is an element of @xs@. class Member (xs :: [k]) (x :: k) where-  membership :: Position xs x+  membership :: Membership xs x  -- | A type sugar to make type error more readable. data Expecting a@@ -138,7 +138,7 @@   Check x xs = Ambiguous x  instance (Check x (Lookup x xs) ~ Expecting one, ToInt one) => Member xs x where-  membership = Position $ theInt (Proxy :: Proxy one)+  membership = Membership $ theInt (Proxy :: Proxy one)   {-# INLINE membership #-}  type family Half (xs :: [k]) :: [k] where
src/Data/Extensible/Internal/Rig.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable#-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Rig@@ -18,6 +18,8 @@ import Data.Monoid import Data.Foldable (Foldable) import Data.Traversable (Traversable)++type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s  -- | @'view' :: Lens' s a -> (a -> a) -> (s -> s)@ view :: ((a -> Const a a) -> (s -> Const a s)) -> s -> a
src/Data/Extensible/Match.hs view
@@ -23,7 +23,7 @@ import Data.Extensible.Sum  -- | A lens for a specific clause.-clause :: (x ∈ xs, Functor f) => ((h x -> a) -> f (h x -> a)) -> Match h a :* xs -> f (Match h a :* xs)+clause :: (x ∈ xs) => Lens' (Match h a :* xs) (h x -> a) clause f = sector (fmap Match . f . runMatch)  -- | Applies a function to the result of 'Match'.
src/Data/Extensible/Plain.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase, TemplateHaskell #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Extensible.Plain@@ -22,6 +23,9 @@   , (<?%)   , K1(..)   , (<?!)+  , accessing+  , decFields+  , decFieldsDeriving   )where import Data.Extensible.Internal import Data.Extensible.Internal.Rig@@ -29,6 +33,9 @@ import Data.Extensible.Sum import Data.Typeable import Unsafe.Coerce+import Language.Haskell.TH hiding (Match(..))+import Data.Char+import Data.Coerce  -- | Alias for plain products type AllOf xs = K0 :* xs@@ -63,7 +70,7 @@ {-# INLINE record #-}  -- | /O(log n)/ A lens for a plain value in a product.-recordAt :: (Functor f) => Position xs x -> (x -> f x) -> (AllOf xs -> f (AllOf xs))+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 #-} @@ -80,3 +87,41 @@ (<?!) :: (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)+{-# INLINE accessing #-}++-- | Generate newtype wrappers and lenses from type synonyms.+--+-- @+-- decFields [d|type Foo = Int|]+-- @+--+-- Generates:+--+-- @+-- newtype Foo = Foo Int+-- foo :: (Foo ∈ xs) => Lens' (AllOf xs) Int+-- foo = accessing Foo+-- @+--+decFields :: DecsQ -> DecsQ+decFields = decFieldsDeriving []++decFieldsDeriving :: [Name] -> DecsQ -> DecsQ+decFieldsDeriving drv' ds = ds >>= fmap concat . mapM mkBody+  where+    mkBody (NewtypeD cx name_ tvs (NormalC nc [(st, ty)]) drv) = do+      let name = let (x:xs) = nameBase name_ in mkName (toLower x : xs)+      xs <- newName "xs"+      sequence [return $ NewtypeD cx name_ tvs (NormalC nc [(st, ty)]) (drv' ++ drv)+        ,sigD name+          $ forallT (PlainTV xs : tvs) (sequence [classP ''Member [varT xs, conT name_]])+          $ 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+        ]+    mkBody (TySynD name_ tvs ty) = mkBody (NewtypeD [] name_ tvs (NormalC (mkName (nameBase name_)) [(NotStrict, ty)]) [])+    mkBody _ = fail "Unsupported declaration: genField handles newtype declarations or type synonyms"
src/Data/Extensible/Product.hs view
@@ -122,27 +122,27 @@ htraverse _ Nil = pure Nil  -- | /O(log n)/ Pick up an elemtnt.-hlookup :: Position xs x -> h :* xs -> h x+hlookup :: Membership xs x -> h :* xs -> h x hlookup = view . sectorAt {-# INLINE hlookup #-}  -- | 'hmap' with its indices.-htabulate :: forall g h xs. (forall x. Position xs x -> g x -> h x) -> g :* xs -> h :* xs+htabulate :: forall g h xs. (forall x. Membership xs x -> g x -> h x) -> g :* xs -> h :* xs htabulate f = go id where-  go :: (forall x. Position t x -> Position xs x) -> g :* t -> h :* t+  go :: (forall x. Membership t x -> Membership xs x) -> g :* t -> h :* t   go k (Tree g a b) = Tree (f (k here) g) (go (k . navL) a) (go (k . navR) b)   go _ Nil = Nil {-# INLINE htabulate #-}  -- | /O(log n)/ A lens for a specific element.-sector :: (Functor f, x ∈ xs) => (h x -> f (h x)) -> h :* xs -> f (h :* xs)+sector :: (x ∈ xs) => Lens' (h :* xs) (h x) sector = sectorAt membership {-# INLINE sector #-}  -- | /O(log n)/ A lens for a value in a known position.-sectorAt :: forall h x xs f. (Functor f) => Position xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs)+sectorAt :: forall h x xs f. Functor f => Membership xs x -> (h x -> f (h x)) -> h :* xs -> f (h :* xs) sectorAt pos0 f = go pos0 where-  go :: forall t. Position t x -> h :* t -> f (h :* t)+  go :: forall t. Membership t x -> h :* t -> f (h :* t)   go pos (Tree h a b) = case navigate pos of     Here -> fmap (\h' -> Tree h' a b) (f h)     NavL p -> fmap (\a' -> Tree h a' b) $ go p a@@ -153,7 +153,7 @@ -- | Given a function that maps types to values, we can "collect" entities all you want. class Generate (xs :: [k]) where   -- | /O(n)/ generates a product with the given function.-  generate :: (forall x. Position xs x -> h x) -> h :* xs+  generate :: (forall x. Membership xs x -> h x) -> h :* xs  instance Generate '[] where   generate _ = Nil@@ -166,7 +166,7 @@ -- | Guarantees the all elements satisfies the predicate. class Forall c (xs :: [k]) where   -- | /O(n)/ Analogous to 'generate', but it also supplies a context @c x@ for every elements in @xs@.-  generateFor :: proxy c -> (forall x. c x => Position xs x -> h x) -> h :* xs+  generateFor :: proxy c -> (forall x. c x => Membership xs x -> h x) -> h :* xs  instance Forall c '[] where   generateFor _ _ = Nil
src/Data/Extensible/Record.hs view
@@ -107,7 +107,6 @@         `appE` (varE '(.) `appE` (varE 'unlabel `appE` lbl `appE` varE f) `appE` varE 'getField)   sequence [tySynInstD ''FieldValue (tySynEqn [litT (strTyLit s)] t)     , sigD (mkName s)-      $ forallT [] (return [])       $ conT ''FieldLens `appT` st     , funD (mkName s) [clause [varP f] (normalB $ varE 'sector `appE` wf) []]     , return $ PragmaD $ InlineP (mkName s) Inline FunLike AllPhases
src/Data/Extensible/Sum.hs view
@@ -27,7 +27,7 @@  -- | The extensible sum type data (h :: k -> *) :| (s :: [k]) where-  UnionAt :: Position xs x -> h x -> h :| xs+  UnionAt :: Membership xs x -> h x -> h :| xs deriving instance Typeable (:|)  -- | Change the wrapper.@@ -42,7 +42,7 @@  -- | /O(1)/ Naive pattern match (<:|) :: (h x -> r) -> (h :| xs -> r) -> h :| (x ': xs) -> r-(<:|) r c = \(UnionAt pos h) -> case runPosition pos of+(<:|) r c = \(UnionAt pos h) -> case runMembership pos of   Left Refl -> r h   Right pos' -> c (UnionAt pos' h) infixr 1 <:|@@ -54,7 +54,7 @@  -- | 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 comparePosition (membership :: Position xs x) pos of+picked f u@(UnionAt pos h) = case compareMembership (membership :: Membership xs x) pos of   Right Refl -> fmap (UnionAt pos) (f h)   _ -> pure u {-# INLINE picked #-}