red-black-record 1.0.0.2 → 1.1.0.0

raw patch · 5 files changed

+51/−24 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• lib/Data/RBR.hs +2/−0
• lib/Data/RBR/Examples.hs +16/−14
• lib/Data/RBR/Internal.hs +25/−9
• red-black-record.cabal +1/−1

@@ -1,5 +1,12 @@ # Revision history for red-black-record
 
+## 1.1.0.0
+
+* Field and Branch type families to help speed up type-level computations. 
+
+  Apparently, having identical invocations of a "costly to compute" type family
+  in a signature slowed things down.
+
 ## 1.0.0.2
 
 * Improved compilation times for getters by refactoring `KeyHelper`.

@@ -24,6 +24,8 @@         FromList,
         -- ** Projecting and injecting
         Key (..),
+        Field,
+        Branch,
         project,
         projectI,
         getField,

@@ -222,18 +222,20 @@  
 >>> :{
     let parseFieldSubset
-              :: forall subset whole flat wholeflat. (KeysValuesAll KnownKey whole, 
-                                                      Productlike '[] whole wholeflat,
-                                                      ProductlikeSubset subset whole flat,
-                                                      All FromJSON wholeflat) 
-              => Data.Aeson.Value 
-              -> Parser (Record I subset)
-        parseFieldSubset = 
+              :: forall subset subflat c flat r. (Generic r, 
+                                                  FromRecord r, 
+                                                  RecordCode r ~ c, 
+                                                  ProductlikeSubset subset c subflat,
+                                                  KeysValuesAll KnownKey subset, 
+                                                  All FromJSON subflat) 
+              => r 
+              -> Data.Aeson.Value
+              -> Parser r 
+        parseFieldSubset r = 
             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
+                objNP = liftA2_NP mapKSS (toNP @subset demoteKeys) (cpure_NP (Proxy @FromJSON) (Star parseJSON)) 
+                intoOriginal subr = fromRecord (setFieldSubset @subset subr (toRecord r))
+                Star subparser = intoOriginal . fromNP @subset <$> sequence_NP objNP
              in withObject "someobj" subparser
     :}
 
@@ -243,16 +245,16 @@ >>> :{ 
     let original = Person "John" 50 True
         Just v = Data.Aeson.decode @Data.Aeson.Value (fromString "{ \"name\" : \"Mark\", \"age\" : 70 }")
-        subsetParser = parseFieldSubset @(FromList [ '("name",_), '("age",_) ]) @(RecordCode Person)
+        subsetParser = parseFieldSubset @(FromList [ '("name",_), '("age",_) ]) original
         Just s = parseMaybe subsetParser v
-     in fromRecord @Person . setFieldSubset s $ toRecord original
+     in s
     :}
 Person {name = "Mark", age = 70, whatever = True}
 
 -}
 
 
-{- $json3
+{- $json4sum
  
     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.

@@ -439,6 +439,25 @@ --
 -- Accessing fields
 
+--
+-- These two type families exist to avoid duplicating expensive type-level
+-- computations, in particular the Value' computations.
+--
+-- Record accessors are compiled WAY slower without them!
+--
+-- TODO: Whould sharing be preserved if I made them type synonyms? Benchmark that.
+
+{- | Auxiliary type family to avoid repetition and help improve compilation times.
+ -}
+type family Field (f :: Type -> Type) (t :: RBT Symbol Type) (v :: Type) where
+    Field f t v = Record f t -> (f v -> Record f t, f v)
+
+{- | Auxiliary type family to avoid repetition and help improve compilation times.
+ -}
+type family Branch (f :: Type -> Type) (t :: RBT Symbol Type) (v :: Type) where
+    Branch f t v = (Variant f t -> Maybe (f v), f v -> Variant f t)
+
+--
 {- | 
      Class that determines if a given 'Symbol' key is present in a type-level
      tree.
@@ -452,18 +471,15 @@      'branch' takes a branch name (given through @TypeApplications@) and
      returns a pair of a match function and a constructor.
 -} 
-
 class Key (k :: Symbol) (t :: RBT Symbol Type) where
     type Value k t :: Type
-    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)
+    field  :: Field  f t (Value k t)
+    branch :: Branch f t (Value k 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))
+    field'  :: Field  f (N colorx left kx v right) (Value' ordering k left v right)
+    branch' :: Branch f (N colorx left kx v right) (Value' ordering k left v right)
 
 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
@@ -472,7 +488,7 @@ 
 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
+    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' @ordering @k @left2 @v2 @right2 right
          in (\z -> Node left fv (setter z),x)
@@ -484,7 +500,7 @@ 
 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
+    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' @ordering @k @left2 @v2 @right2 left
          in (\z -> Node (setter z) fv right,x)

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