red-black-record 1.0.0.1 → 1.0.0.2

raw patch · 5 files changed

+132/−49 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• README.md +37/−17
• lib/Data/RBR/Examples.hs +65/−10
• lib/Data/RBR/Internal.hs +24/−20
• red-black-record.cabal +1/−1

@@ -1,5 +1,9 @@ # Revision history for red-black-record
 
-## 1.0.0.0 -- YYYY-mm-dd
+## 1.0.0.2
+
+* Improved compilation times for getters by refactoring `KeyHelper`.
+
+## 1.0.0.0
 
 * First version. Released on an unsuspecting world.

@@ -1,6 +1,8 @@-# red-black-record
+red-black-record
+================
 
-## What's this?
+What's this?
+------------
 
 A library that provides extensible records and variants, both indexed by a
 type-level [red-black](https://en.wikipedia.org/wiki/Red%E2%80%93black_tree)
@@ -36,25 +38,22 @@ For examples on how to use the library, check the haddocks for the
 `Data.RBR.Examples` module.
 
-## FAQ
+FAQ
+---
 
 ### What extensions do I need to use this library?
 
-- `DataKinds`
-
-- `TypeApplications`
-
-  To be able to specify field and branch names.
+- `DataKinds`.
 
-- `FlexibleContexts`
+- `TypeApplications` to be able to specify field and branch names.
 
-- `TypeFamilies`
+- `TypeFamilies`.
 
-- `DeriveGeneric `
+- `FlexibleContexts`.
 
-  For interfacing with normal records.
+- `DeriveGeneric` for interfacing with normal records.
 
-- `PartialTypeSignatures`
+- `PartialTypeSignatures` for hiding complex tree types.
 
 ### My type signatures are getting big and scary because of those type-level trees. What to do?
 
@@ -129,8 +128,25 @@ That isn't implemented (yet). It would require key deletion on the type-level
 tree.
 
-## Inspirations
+### What about compilation times?
 
+Sadly, compilation times balloon for large records. In the tests folder there's
+an example (not run by default in the tests) of the construction of a 50-field
+record whose fields are afterwards accessed one by one. It takes on the order
+of one minute to compile in my machine. 
+
+Surprisingly perhaps, most of the compilation time is *not* spent in the
+construction of the record itself, but in checking the applicability of the
+getters. If one removes the getter accesses, the program compiles more than
+twice faster. 
+
+The default generics-based implementations of `FromRecord` and `FromVariant`
+use the same type-level machinery as the getters and its use will likely slow
+down compilation as well :(
+
+Inspirations
+------------
+
 - The code for the red-black tree has been lifted from ["Persistent Red Black
   Trees in Haskell"](https://abhiroop.github.io/Haskell-Red-Black-Tree/).
 
@@ -142,7 +158,8 @@   types](https://blog.poisson.chat/posts/2018-11-26-type-surgery.html).
   [reddit](https://www.reddit.com/r/haskell/comments/a0gi4z/surgery_for_data_types/).
 
-## Alternatives
+Alternatives
+------------
 
 - [generics-sop](http://hackage.haskell.org/package/generics-sop) and
   [records-sop](http://hackage.haskell.org/package/records-sop). Like
@@ -179,7 +196,10 @@   extension](https://github.com/ghc-proposals/ghc-proposals/pull/180) for
   Haskell.
 
-- [generic-data-surgery](https://hackage.haskell.org/package/generic-data-surgery)
+- [generic-data-surgery](https://hackage.haskell.org/package/generic-data-surgery).
+  Lots of useful machinery for manipulating generic representations of
+  dataytpes, without requiring intrusive changes to the original
+  representation.
 
-- [Coxswain](https://ghc.haskell.org/trac/ghc/wiki/Plugins/TypeChecker/RowTypes/Coxswain)
+- [Coxswain](https://ghc.haskell.org/trac/ghc/wiki/Plugins/TypeChecker/RowTypes/Coxswain).
 

@@ -22,6 +22,9 @@    
     -- * Parsing a subset of a record's fields from JSON and inserting them in an existing record value
     -- $json3
+    
+    -- * Ensuring all branches of a sum type are parsed from JSON
+    -- $json4sum
     ) where
 
 import Data.RBR
@@ -36,9 +39,10 @@ >>> :set -Wno-partial-type-signatures  
 >>> import Data.RBR
 >>> import Data.SOP
->>> import Data.SOP.NP (cpure_NP,sequence_NP,liftA2_NP)
+>>> import Data.SOP.NP (cpure_NP,sequence_NP,liftA2_NP,collapse_NP)
 >>> import Data.String
 >>> import Data.Proxy
+>>> import Data.Foldable
 >>> import Data.Profunctor (Star(..))
 >>> import GHC.Generics
 >>> import qualified Data.Text
@@ -149,8 +153,8 @@               -> Data.Aeson.Value 
               -> Parser r
         parseSpecial transform = 
-            let pr = transform $ fromNP @c (cpure_NP (Proxy @FromJSON) (Star parseJSON))
-                mapKSS (K name) (Star pf) = Star (\o -> explicitParseField pf o (Data.Text.pack name))
+            let mapKSS (K name) (Star pf) = Star (\o -> explicitParseField pf o (Data.Text.pack name))
+                pr = transform $ fromNP @c (cpure_NP (Proxy @FromJSON) (Star parseJSON))
                 Star parser = fromNP <$> sequence_NP (liftA2_NP mapKSS (toNP @c demoteKeys) (toNP pr))
              in withObject "someobj" $ \o -> fromRecord <$> parser o
     :}
@@ -171,9 +175,9 @@ 
 {- $json2
  
-   We have to use 'getFieldSubset' because the aliases are listed in a
-   different order than the record fields, and that might result in different
-   type-level trees. If the orders were the same, we wouldn't need it. 
+    The aliases are passed as a 'Record' with values wrapped in the 'K'
+    functor. This means that there aren't really any values of the type that
+    corresponds to each field, only the `String` annotations.
 
 >>> :{
     let parseWithAliases
@@ -186,12 +190,16 @@               -> Data.Aeson.Value 
               -> Parser r
         parseWithAliases aliases = 
-            let pr = fromNP @c (cpure_NP (Proxy @FromJSON) (Star parseJSON))
-                mapKSS (K name) (Star pf) = Star (\o -> explicitParseField pf o (Data.Text.pack name))
+            let mapKSS (K name) (Star pf) = Star (\o -> explicitParseField pf o (Data.Text.pack name))
+                pr = fromNP @c (cpure_NP (Proxy @FromJSON) (Star parseJSON))
                 Star parser = fromNP <$> sequence_NP (liftA2_NP mapKSS (toNP @c aliases) (toNP pr))
              in withObject "someobj" $ \o -> fromRecord <$> parser o
     :}
 
+   We have to use 'getFieldSubset' because the aliases are listed in a
+   different order than the record fields, and that might result in different
+   type-level trees. If the orders were the same, we wouldn't need it. 
+
 >>> data Person = Person { name :: String, age :: Int } deriving (Generic, Show)
 >>> instance ToRecord Person 
 >>> instance FromRecord Person 
@@ -221,8 +229,8 @@               => Data.Aeson.Value 
               -> Parser (Record I subset)
         parseFieldSubset = 
-            let pNP = cpure_NP (Proxy @FromJSON) (Star parseJSON)
-                mapKSS (K name) (Star pf) = Star (\o -> explicitParseField pf o (Data.Text.pack name))
+            let mapKSS (K name) (Star pf) = Star (\o -> explicitParseField pf o (Data.Text.pack name))
+                pNP = cpure_NP (Proxy @FromJSON) (Star parseJSON)
                 objpNP = liftA2_NP mapKSS (toNP @whole demoteKeys) pNP
                 subNP = toNP @subset $ getFieldSubset @subset $ fromNP @whole objpNP
                 Star subparser = fromNP @subset <$> sequence_NP subNP
@@ -242,3 +250,50 @@ Person {name = "Mark", age = 70, whatever = True}
 
 -}
+
+
+{- $json3
+ 
+    To ensure that we don't forget any branch when parsing a sum type from JSON, 
+    we can create a n-ary product of parsers, one for each branch.
+
+    Then we create a n-ary product of injections. Each component of the
+    product creates a n-ary sum out of the value of the corresponding branch.
+
+    We combine the n-ary product of parsers with the n-ary product of
+    injections, and collapse all the resulting parsers with
+    'Control.Applicative.asum'.
+
+    Then we convert the n-ary sum value that "wins" into a 'Variant' and
+    finally back into the original type.
+
+>>> :{
+    let parseAll
+              :: forall r c flat. (Generic r, 
+                                   FromVariant r, 
+                                   VariantCode r ~ c, 
+                                   KeysValuesAll KnownKey c, 
+                                   Productlike '[] c flat, 
+                                   Sumlike '[] c flat, 
+                                   All FromJSON flat) 
+              => Data.Aeson.Value 
+              -> Parser r
+        parseAll = 
+            let mapKSS (K name) (Star pf) = Star (\o -> explicitParseField pf o (Data.Text.pack name))
+                pnp = liftA2_NP mapKSS (toNP @c demoteKeys) (cpure_NP (Proxy @FromJSON) (Star parseJSON))
+                injected = liftA2_NP (\f star -> K (unK . apFn f . I <$> star)) (injections @flat) pnp 
+                Star parser = asum $ collapse_NP injected
+             in withObject "someobj" (\o -> fromVariant @r . fromNS <$> parser o)
+    :}
+
+>>> data ThisOrThat = This String | That Int deriving (Generic, Show)
+>>> instance FromVariant ThisOrThat
+>>> :{ 
+    let Just v = Data.Aeson.decode @Data.Aeson.Value (fromString "{ \"That\" : 70 }")
+        Just s = parseMaybe (parseAll @ThisOrThat) v
+     in s
+    :}
+That 70
+
+-}
+

@@ -180,7 +180,8 @@ 
 {- | Like 'prettyShowVariant' but specialized to pure variants.
 -}
-prettyShowVariantI :: forall t flat. (KeysValuesAll KnownKey t,Productlike '[] t flat, Sumlike '[] t flat, All Show flat, SListI flat) => Variant I t -> String
+prettyShowVariantI :: forall t flat. (KeysValuesAll KnownKey t,Productlike '[] t flat, Sumlike '[] t flat, All Show flat, SListI flat) 
+                   => Variant I t -> String
 prettyShowVariantI v = prettyShowVariant (show . unI) v 
 
 --
@@ -457,41 +458,44 @@     field :: Record f t -> (f (Value k t) -> Record f t, f (Value k t))
     branch :: (Variant f t -> Maybe (f (Value k t)), f (Value k t) -> Variant f t)
 
-class KeyHelper (ordering :: Ordering) (k :: Symbol) (t :: RBT Symbol Type) where 
-    type Value' ordering k t :: Type
-    field' :: Record f t -> (f (Value' ordering k t) -> Record f t, f (Value' ordering k t))
-    branch' :: (Variant f t -> Maybe (f (Value' ordering k t)), f (Value' ordering k t) -> Variant f t)
+class KeyHelper (ordering :: Ordering) (k :: Symbol) (left :: RBT Symbol Type) (v :: Type) (right :: RBT Symbol Type) where 
+    type Value' ordering k left v right :: Type
+    field' :: Record f (N colorx left kx v right) -> (f (Value' ordering k left v right) -> Record f (N colorx left kx v right), 
+                                                      f (Value' ordering k left v right))
+    branch' :: (Variant f (N colorx left kx v right) -> Maybe (f (Value' ordering k left v right)), 
+                f (Value' ordering k left v right) -> Variant f (N colorx left kx v right))
 
-instance (CmpSymbol k' k ~ ordering, KeyHelper ordering k (N color left k' v' right)) 
-         => Key k (N color left k' v' right) where
-    type Value k (N color left k' v' right) = Value' (CmpSymbol k' k) k (N color left k' v' right)
-    field = field' @ordering @k
-    branch = branch' @ordering @k
+instance (CmpSymbol k' k ~ ordering, KeyHelper ordering k left v' right) => Key k (N color left k' v' right) where
+    type Value k (N color left k' v' right) = Value' (CmpSymbol k' k) k left v' right
+    field = field' @ordering @k @left @v' @right
+    branch = branch' @ordering @k @left @v' @right
 
-instance Key k right => KeyHelper LT k (N color left k' v' right) where
-    type Value' LT k (N color left k' v' right) = Value k right
+instance (CmpSymbol k2 k ~ ordering, KeyHelper ordering k left2 v2 right2) 
+      => KeyHelper LT k left v (N color2 left2 k2 v2 right2) where
+    type Value' LT k left v (N color2 left2 k2 v2 right2) = Value' (CmpSymbol k2 k) k left2 v2 right2
     field' (Node left fv right) = 
-        let (setter,x) = field @k right
+        let (setter,x) = field' @ordering @k @left2 @v2 @right2 right
          in (\z -> Node left fv (setter z),x)
     branch' = 
-        let (match,inj) = branch @k @right
+        let (match,inj) = branch' @ordering @k @left2 @v2 @right2 
          in (\case LookRight x -> match x
                    _ -> Nothing,
              \fv -> LookRight (inj fv))
 
-instance Key k left => KeyHelper GT k (N color left k' v' right) where
-    type Value' GT k (N color left k' v' right) = Value k left
+instance (CmpSymbol k2 k ~ ordering, KeyHelper ordering k left2 v2 right2) 
+      => KeyHelper GT k (N color2 left2 k2 v2 right2) v' right where
+    type Value' GT k (N color2 left2 k2 v2 right2) v' right = Value' (CmpSymbol k2 k) k left2 v2 right2
     field' (Node left fv right) = 
-        let (setter,x) = field @k left
+        let (setter,x) = field' @ordering @k @left2 @v2 @right2 left
          in (\z -> Node (setter z) fv right,x)
     branch' =
-        let (match,inj) = branch @k @left
+        let (match,inj) = branch' @ordering @k @left2 @v2 @right2 
          in (\case LookLeft x -> match x
                    _ -> Nothing,
              \fv -> LookLeft (inj fv))
 
-instance KeyHelper EQ k (N color left k v right) where
-    type Value' EQ k (N color left k v right) = v
+instance KeyHelper EQ k left v right where
+    type Value' EQ k left v right = v
     field' (Node left fv right) = (\x -> Node left x right, fv)
     branch' = (\case Here x -> Just x
                      _ -> Nothing,

@@ -1,6 +1,6 @@ cabal-version:       2.0
 name:                red-black-record
-version:             1.0.0.1
+version:             1.0.0.2
 synopsis:            Extensible records and variants indexed by a type-level Red-Black tree.
 
 description:         A library that provides extensible records and variants,