row-types 0.2.2.0 → 0.2.3.0

raw patch · 6 files changed

+174/−77 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• Data/Row/Internal.hs +39/−38
• Data/Row/Records.hs +110/−18
• Data/Row/Variants.hs +14/−15
• examples/Examples.lhs +5/−5
• row-types.cabal +1/−1

@@ -1,4 +1,9 @@ +## 0.2.3.0 [2018-07-02]+- Update the Show instance to render valid code.+- Add 'toNative' and 'fromNative' functions for records to easily convert between Haskell records and row-types records.+- Make type families in Data.Row.Internal polykinded (thanks James Yu!)+ ## 0.2.1.0 [2018-03-20] - Bug Fix: The type of 'update' for both Record and Variant now enforce the newly inserted type is correct. - New: Add 'restrict' and 'split' for Variants.  

@@ -110,44 +110,45 @@  infixl 4 .\ {- This comment needed to appease CPP -} -- | Does the row lack (i.e. it does not have) the specified label?-type family (r :: Row *) .\ (l :: Symbol) :: Constraint where+type family (r :: Row k) .\ (l :: Symbol) :: Constraint where   R r .\ l = LacksR l r r  -- | Type level Row extension-type family Extend (l :: Symbol) (a :: *) (r :: Row *) :: Row * where+type family Extend (l :: Symbol) (a :: k) (r :: Row k) :: Row k where   Extend l a (R x) = R (Inject (l :-> a) x)  -- | Type level Row modification-type family Modify (l :: Symbol) (a :: *) (r :: Row *) :: Row * where+type family Modify (l :: Symbol) (a :: k) (r :: Row k) :: Row k where   Modify l a (R ρ) = R (ModifyR l a ρ)  -- | Type level row renaming-type family Rename (l :: Symbol) (l' :: Symbol) (r :: Row *) :: Row * where+type family Rename (l :: Symbol) (l' :: Symbol) (r :: Row k) :: Row k where   Rename l l' r = Extend  l' (r .! l) (r .- l)  infixl 5 .! -- | Type level label fetching-type family (r :: Row *) .! (t :: Symbol) :: * where+type family (r :: Row k) .! (t :: Symbol) :: k where   R r .! l = Get l r  infixl 6 .- -- | Type level Row element removal-type family (r :: Row *) .- (s :: Symbol) :: Row * where+type family (r :: Row k) .- (s :: Symbol) :: Row k where   R r .- l = R (Remove l r)  infixl 6 .+ -- | Type level Row append-type family (l :: Row *) .+ (r :: Row *) :: Row * where+type family (l :: Row k) .+ (r :: Row k) :: Row k where   R l .+ R r = R (Merge l r)  infixl 6 .\\ {- This comment needed to appease CPP -} -- | Type level Row difference.  That is, @l .\\\\ r@ is the row remaining after -- removing any matching elements of @r@ from @l@.-type family (l :: Row *) .\\ (r :: Row *) :: Row * where+type family (l :: Row k) .\\ (r :: Row k) :: Row k where   R l .\\ R r = R (Diff l r) +infixl 6 .\/ -- | The minimum join of the two rows.-type family (l :: Row *) .\/ (r :: Row *) where+type family (l :: Row k) .\/ (r :: Row k) where   R l .\/ R r = R (MinJoinR l r)  @@ -167,7 +168,7 @@  -- | A type level way to create a singleton Row. infix 7 .==-type (l :: Symbol) .== (a :: *) = Extend l a Empty+type (l :: Symbol) .== (a :: k) = Extend l a Empty   {--------------------------------------------------------------------@@ -181,10 +182,10 @@  -- | Any structure over a row in which every element is similarly constrained can --   be metamorphized into another structure over the same row.-class Forall (r :: Row *) (c :: * -> Constraint) where+class Forall (r :: Row k) (c :: k -> Constraint) where   -- | A metamorphism is an unfold followed by a fold.  This one is for   -- product-like row-types (e.g. Rec).-  metamorph :: forall (f :: Row * -> *) (g :: Row * -> *) (h :: * -> *).+  metamorph :: forall (f :: Row k -> *) (g :: Row k -> *) (h :: k -> *).                Proxy h             -> (f Empty -> g Empty)                -- ^ The way to transform the empty element@@ -197,7 +198,7 @@    -- | A metamorphism is an unfold followed by a fold.  This one is for   -- sum-like row-types (e.g. Var).-  metamorph' :: forall (f :: Row * -> *) (g :: Row * -> *) (h :: * -> *).+  metamorph' :: forall (f :: Row k -> *) (g :: Row k -> *) (h :: k -> *).                Proxy h             -> (f Empty -> g Empty)                -- ^ The way to transform the empty element@@ -223,11 +224,11 @@   as = As  -- | An internal type used by the 'metamorph' in 'mapForall'.-newtype MapForall c f (r :: Row *) = MapForall { unMapForall :: Dict (Forall (Map f r) (IsA c f)) }+newtype MapForall c f (r :: Row k) = MapForall { unMapForall :: Dict (Forall (Map f r) (IsA c f)) }  -- | This allows us to derive a `Forall (Map f r) ..` from a `Forall r ..`. mapForall :: forall f c ρ. Forall ρ c :- Forall (Map f ρ) (IsA c f)-mapForall = Sub $ unMapForall $ metamorph @ρ @c @(Const ()) @(MapForall c f) @(Const ()) Proxy empty uncons cons $ Const ()+mapForall = Sub $ unMapForall $ metamorph @_ @ρ @c @(Const ()) @(MapForall c f) @(Const ()) Proxy empty uncons cons $ Const ()   where empty :: Const () Empty -> MapForall c f Empty         empty _ = MapForall Dict @@ -256,8 +257,8 @@   {-# INLINE metamorph' #-}   metamorph' _ empty _ _ = empty -instance (KnownSymbol ℓ, c τ, FoldStep ℓ τ ρ, Forall ('R ρ) c) => Forall ('R (ℓ :-> τ ': ρ)) c where-  metamorph :: forall (f :: Row * -> *) (g :: Row * -> *) (h :: * -> *).+instance (KnownSymbol ℓ, c τ, FoldStep ℓ τ ρ, Forall ('R ρ) c) => Forall ('R (ℓ :-> τ ': ρ) :: Row k) c where+  metamorph :: forall (f :: Row k -> *) (g :: Row k -> *) (h :: k -> *).                Proxy h             -> (f Empty -> g Empty)                -- ^ The way to transform the empty element@@ -268,9 +269,9 @@             -> f ('R (ℓ :-> τ ': ρ))  -- ^ The input structure             -> g ('R (ℓ :-> τ ': ρ))   {-# INLINE metamorph #-}-  metamorph _ empty uncons cons r = cons Label t $ metamorph @('R ρ) @c @_ @_ @h Proxy empty uncons cons r'+  metamorph _ empty uncons cons r = cons Label t $ metamorph @_ @('R ρ) @c @_ @_ @h Proxy empty uncons cons r'     where (t, r') = uncons Label r-  metamorph' :: forall (f :: Row * -> *) (g :: Row * -> *) (h :: * -> *).+  metamorph' :: forall (f :: Row k -> *) (g :: Row k -> *) (h :: k -> *).                Proxy h             -> (f Empty -> g Empty)                -- ^ The way to transform the empty element@@ -281,17 +282,17 @@             -> f ('R (ℓ :-> τ ': ρ))  -- ^ The input structure             -> g ('R (ℓ :-> τ ': ρ))   {-# INLINE metamorph' #-}-  metamorph' _ empty uncons cons r = cons Label $ metamorph' @('R ρ) @c @_ @_ @h Proxy empty uncons cons <$> uncons Label r+  metamorph' _ empty uncons cons r = cons Label $ metamorph' @_ @('R ρ) @c @_ @_ @h Proxy empty uncons cons <$> uncons Label r  -- | Any structure over two rows in which every element of both rows satisfies the --   given constraint can be metamorphized into another structure over both of the --   rows. -- TODO: Perhaps it should be over two constraints?  But this hasn't seemed necessary --  in practice.-class Forall2 (r1 :: Row *) (r2 :: Row *) (c :: * -> Constraint) where+class Forall2 (r1 :: Row k) (r2 :: Row k) (c :: k -> Constraint) where   -- | A metamorphism is a fold followed by an unfold.  Here, we fold both of the inputs.-  metamorph2 :: forall (f :: Row * -> *) (g :: Row * -> *) (h :: Row * -> Row * -> *)-                       (f' :: * -> *) (g' :: * -> *).+  metamorph2 :: forall (f :: Row k -> *) (g :: Row k -> *) (h :: Row k -> Row k -> *)+                       (f' :: k -> *) (g' :: k -> *).                 Proxy f' -> Proxy g'              -> (f Empty -> g Empty -> h Empty Empty)              -> (forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ, c τ1, c τ2)@@ -310,7 +311,7 @@ instance (KnownSymbol ℓ, c τ1, c τ2, Forall2 ('R ρ1) ('R ρ2) c)       => Forall2 ('R (ℓ :-> τ1 ': ρ1)) ('R (ℓ :-> τ2 ': ρ2)) c where   {-# INLINE metamorph2 #-}-  metamorph2 f g empty uncons cons r1 r2 = cons (Label @ℓ) t1 t2 $ metamorph2 @('R ρ1) @('R ρ2) @c f g empty uncons cons r1' r2'+  metamorph2 f g empty uncons cons r1 r2 = cons (Label @ℓ) t1 t2 $ metamorph2 @_ @('R ρ1) @('R ρ2) @c f g empty uncons cons r1' r2'     where ((t1, r1'), (t2, r2')) = uncons (Label @ℓ) r1 r2  -- | A null constraint@@ -328,7 +329,7 @@  -- | Return a list of the labels in a row type. labels :: forall ρ c s. (IsString s, Forall ρ c) => [s]-labels = getConst $ metamorph @ρ @c @(Const ()) @(Const [s]) @(Const ()) Proxy (const $ Const []) doUncons doCons (Const ())+labels = getConst $ metamorph @_ @ρ @c @(Const ()) @(Const [s]) @(Const ()) Proxy (const $ Const []) doUncons doCons (Const ())   where doUncons _ _ = (Const (), Const ())         doCons l _ (Const c) = Const $ show' l : c @@ -345,10 +346,10 @@ type WellBehaved ρ = (Forall ρ Unconstrained1, AllUniqueLabels ρ)  -- | Are all of the labels in this Row unique?-type family AllUniqueLabels (r :: Row *) :: Constraint where+type family AllUniqueLabels (r :: Row k) :: Constraint where   AllUniqueLabels (R r) = AllUniqueLabelsR r -type family AllUniqueLabelsR (r :: [LT *]) :: Constraint where+type family AllUniqueLabelsR (r :: [LT k]) :: Constraint where   AllUniqueLabelsR '[] = Unconstrained   AllUniqueLabelsR '[l :-> a] = Unconstrained   AllUniqueLabelsR (l :-> a ': l :-> b ': _) = TypeError@@ -357,10 +358,10 @@   AllUniqueLabelsR (l :-> a ': l' :-> b ': r) = AllUniqueLabelsR (l' :-> b ': r)  -- | Is the first row a subset of the second?-type family Subset (r1 :: Row *) (r2 :: Row *) :: Constraint where+type family Subset (r1 :: Row k) (r2 :: Row k) :: Constraint where   Subset (R r1) (R r2) = SubsetR r1 r2 -type family SubsetR (r1 :: [LT *]) (r2 :: [LT *]) :: Constraint where+type family SubsetR (r1 :: [LT k]) (r2 :: [LT k]) :: Constraint where   SubsetR '[] _ = Unconstrained   SubsetR x '[] = TypeError (TL.Text "One row-type is not a subset of the other."         :$$: TL.Text "The first contains the bindings " :<>: ShowType x@@ -407,7 +408,7 @@   ZipR '[] (l :-> t ': r) = TypeError (TL.Text "Row types with different label sets cannot be zipped"                                   :$$: TL.Text "For one, the label " :<>: ShowType l :<>: TL.Text " is not in both lists.") -type family Inject (l :: LT *) (r :: [LT *]) where+type family Inject (l :: LT k) (r :: [LT k]) where   Inject (l :-> t) '[] = (l :-> t ': '[])   Inject (l :-> t) (l :-> t' ': x) = TypeError (TL.Text "Cannot inject a label into a row type that already has that label"                                   :$$: TL.Text "The label " :<>: ShowType l :<>: TL.Text " was already assigned the type "@@ -419,7 +420,7 @@       (l' :-> t' ': Inject (l :-> t)  x)  -- | Type level Row modification helper-type family ModifyR (l :: Symbol) (a :: *) (ρ :: [LT *]) :: [LT *] where+type family ModifyR (l :: Symbol) (a :: k) (ρ :: [LT k]) :: [LT k] where   ModifyR l a (l :-> a' ': ρ) = l :-> a ': ρ   ModifyR l a (l' :-> a' ': ρ) = l' :-> a' ': ModifyR l a ρ   ModifyR l a '[] = TypeError (TL.Text "Tried to modify the label " :<>: ShowType l@@ -429,28 +430,28 @@   Ifte True  t f = t   Ifte False t f = f -type family Get (l :: Symbol) (r :: [LT *]) where+type family Get (l :: Symbol) (r :: [LT k]) where   Get l '[] = TypeError (TL.Text "No such field: " :<>: ShowType l)   Get l (l :-> t ': x) = t   Get l (l' :-> t ': x) = Get l x -type family Remove (l :: Symbol) (r :: [LT *]) where+type family Remove (l :: Symbol) (r :: [LT k]) where   Remove l r = RemoveT l r r -type family RemoveT (l :: Symbol) (r :: [LT *]) (r_orig :: [LT *]) where+type family RemoveT (l :: Symbol) (r :: [LT k]) (r_orig :: [LT k]) where   RemoveT l (l :-> t ': x) _ = x   RemoveT l (l' :-> t ': x) r = l' :-> t ': RemoveT l x r   RemoveT l '[] r = TypeError (TL.Text "Cannot remove a label that does not occur in the row type."                           :$$: TL.Text "The label " :<>: ShowType l :<>: TL.Text " is not in "                           :<>: ShowType r) -type family LacksR (l :: Symbol) (r :: [LT *]) (r_orig :: [LT *]) :: Constraint where+type family LacksR (l :: Symbol) (r :: [LT k]) (r_orig :: [LT k]) :: Constraint where   LacksR l '[] _ = Unconstrained   LacksR l (l :-> t ': x) r = TypeError (TL.Text "The label " :<>: ShowType l                                     :<>: TL.Text " already exists in " :<>: ShowType r)   LacksR l (l' :-> _ ': x) r = Ifte (l <=.? l') Unconstrained (LacksR l x r) -type family Merge (l :: [LT *]) (r :: [LT *]) where+type family Merge (l :: [LT k]) (r :: [LT k]) where   Merge '[] r = r   Merge l '[] = l   Merge (h :-> a ': tl)   (h :-> b ': tr) =@@ -461,7 +462,7 @@       (hl :-> al ': Merge tl (hr :-> ar ': tr))       (hr :-> ar ': Merge (hl :-> al ': tl) tr) -type family MinJoinR (l :: [LT *]) (r :: [LT *]) where+type family MinJoinR (l :: [LT k]) (r :: [LT k]) where   MinJoinR '[] r = r   MinJoinR l '[] = l   MinJoinR (h :-> a ': tl)   (h :-> a ': tr) =@@ -476,7 +477,7 @@   -- | Returns the left list with all of the elements from the right list removed.-type family Diff (l :: [LT *]) (r :: [LT *]) where+type family Diff (l :: [LT k]) (r :: [LT k]) where   Diff '[] r = '[]   Diff l '[] = l   Diff (l :-> al ': tl) (l :-> al ': tr) = Diff tl tr

@@ -38,6 +38,9 @@   -- * Combine   -- ** Disjoint union   , type (.+), (.+), Disjoint, pattern (:+)+  -- * Native Conversion+  -- $native+  , toNative, fromNative   -- * Row operations   -- ** Map   , Map, map, map'@@ -76,6 +79,7 @@ import Data.String (IsString) import Data.Text (Text) +import qualified GHC.Generics as G import GHC.TypeLits  import Unsafe.Coerce@@ -91,8 +95,20 @@   OR :: HashMap Text HideType -> Rec r  instance Forall r Show => Show (Rec r) where-  show r = "{ " ++ L.intercalate ", " binds ++ " }"-    where binds = (\ (x, y) -> x ++ "=" ++ y) <$> eraseWithLabels @Show show r+  showsPrec p r =+    case eraseWithLabels @Show (showsPrec 7) r of+      [] ->+        showString "empty"+      xs ->+        showParen+          (p > 6)+          (mconcat (L.intersperse (showString " .+ ") (L.map binds xs)))+    where+      binds (label, value) =+        showChar '#' .+        showString label .+        showString " .== " .+        value  instance Forall r Eq => Eq (Rec r) where   r == r' = and $ eraseZip @Eq (==) r r'@@ -108,7 +124,7 @@   maxBound = default' @Bounded maxBound  instance Forall r NFData => NFData (Rec r) where-  rnf r = getConst $ metamorph @r @NFData @Rec @(Const ()) @Identity Proxy empty doUncons doCons r+  rnf r = getConst $ metamorph @_ @r @NFData @Rec @(Const ()) @Identity Proxy empty doUncons doCons r     where empty = const $ Const ()           doUncons l r = (Identity $ r .! l, unsafeRemove l r)           doCons _ x r = deepseq x $ deepseq r $ Const ()@@ -234,7 +250,7 @@  -- | A fold with labels eraseWithLabels :: forall c ρ s b. (Forall ρ c, IsString s) => (forall a. c a => a -> b) -> Rec ρ -> [(s,b)]-eraseWithLabels f = getConst . metamorph @ρ @c @Rec @(Const [(s,b)]) @Identity Proxy doNil doUncons doCons+eraseWithLabels f = getConst . metamorph @_ @ρ @c @Rec @(Const [(s,b)]) @Identity Proxy doNil doUncons doCons   where doNil _ = Const []         doUncons l r = (Identity $ r .! l, unsafeRemove l r)         doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)@@ -243,7 +259,7 @@  -- | A fold over two row type structures at once eraseZip :: forall c ρ b. Forall ρ c => (forall a. c a => a -> a -> b) -> Rec ρ -> Rec ρ -> [b]-eraseZip f x y = getConst $ metamorph @ρ @c @(Product Rec Rec) @(Const [b]) @IPair Proxy (const $ Const []) doUncons doCons (Pair x y)+eraseZip f x y = getConst $ metamorph @_ @ρ @c @(Product Rec Rec) @(Const [b]) @IPair Proxy (const $ Const []) doUncons doCons (Pair x y)   where doUncons l (Pair r1 r2) = (iPair a b, Pair r1' r2')           where (a, r1') = (r1 .! l, unsafeRemove l r1)                 (b, r2') = (r2 .! l, unsafeRemove l r2)@@ -263,7 +279,7 @@  -- | A function to map over a record given a constraint. map :: forall c f r. Forall r c => (forall a. c a => a -> f a) -> Rec r -> Rec (Map f r)-map f = unRMap . metamorph @r @c @Rec @(RMap f) @Identity Proxy doNil doUncons doCons+map f = unRMap . metamorph @_ @r @c @Rec @(RMap f) @Identity Proxy doNil doUncons doCons   where     doNil _ = RMap empty     doUncons l r = (Identity $ r .! l, unsafeRemove l r)@@ -279,8 +295,8 @@ -- record transformer to convert a record of @f a@ values to a record of @g a@ -- values.  If no constraint is needed, instantiate the first type argument with -- 'Unconstrained1' or use 'transform''.-transform :: forall c r f g. Forall r c => (forall a. c a => f a -> g a) -> Rec (Map f r) -> Rec (Map g r)-transform f = unRMap . metamorph @r @c @(RMap f) @(RMap g) @f Proxy doNil doUncons doCons . RMap+transform :: forall c r (f :: * -> *) (g :: * -> *). Forall r c => (forall a. c a => f a -> g a) -> Rec (Map f r) -> Rec (Map g r)+transform f = unRMap . metamorph @_ @r @c @(RMap f) @(RMap g) @f Proxy doNil doUncons doCons . RMap   where     doNil _ = RMap empty     doUncons l (RMap r) = (r .! l, RMap $ unsafeRemove l r)@@ -289,13 +305,13 @@     doCons l v (RMap r) = RMap (unsafeInjectFront l (f v) r)  -- | A version of 'transform' for when there is no constraint.-transform' :: forall r f g. Forall r Unconstrained1 => (forall a. f a -> g a) -> Rec (Map f r) -> Rec (Map g r)+transform' :: forall r (f :: * -> *) (g :: * -> *). Forall r Unconstrained1 => (forall a. f a -> g a) -> Rec (Map f r) -> Rec (Map g r) transform' = transform @Unconstrained1 @r  -- | A version of 'sequence' in which the constraint for 'Forall' can be chosen. sequence' :: forall f r c. (Forall r c, Applicative f)           => Rec (Map f r) -> f (Rec r)-sequence' = getCompose . metamorph @r @c @(RMap f) @(Compose f Rec) @f Proxy doNil doUncons doCons . RMap+sequence' = getCompose . metamorph @_ @r @c @(RMap f) @(Compose f Rec) @f Proxy doNil doUncons doCons . RMap   where     doNil _ = Compose (pure empty)     doUncons l (RMap r) = (r .! l, RMap $ unsafeRemove l r)@@ -316,9 +332,9 @@ -- >>> uncompose . compose = id  -- | A version of 'compose' in which the constraint for 'Forall' can be chosen.-compose' :: forall c (f :: * -> *) g r . Forall r c+compose' :: forall c (f :: * -> *) (g :: * -> *) (r :: Row *) . Forall r c         => Rec (Map f (Map g r)) -> Rec (Map (Compose f g) r)-compose' = unRMap . metamorph @r @c @(RMap2 f g) @(RMap (Compose f g)) @(Compose f g) Proxy doNil doUncons doCons . RMap2+compose' = unRMap . metamorph @_ @r @c @(RMap2 f g) @(RMap (Compose f g)) @(Compose f g) Proxy doNil doUncons doCons . RMap2   where     doNil _ = RMap empty     doUncons l (RMap2 r) = (Compose $ r .! l, RMap2 $ unsafeRemove l r)@@ -326,14 +342,14 @@  -- | Convert from a record where two functors have been mapped over the types to -- one where the composition of the two functors is mapped over the types.-compose :: forall (f :: * -> *) g r . Forall r Unconstrained1+compose :: forall (f :: * -> *) (g :: * -> *) r . Forall r Unconstrained1         => Rec (Map f (Map g r)) -> Rec (Map (Compose f g) r) compose = compose' @Unconstrained1 @f @g @r  -- | A version of 'uncompose' in which the constraint for 'Forall' can be chosen.-uncompose' :: forall c (f :: * -> *) g r . Forall r c+uncompose' :: forall c (f :: * -> *) (g :: * -> *) r . Forall r c            => Rec (Map (Compose f g) r) -> Rec (Map f (Map g r))-uncompose' = unRMap2 . metamorph @r @c @(RMap (Compose f g)) @(RMap2 f g) @(Compose f g) Proxy doNil doUncons doCons . RMap+uncompose' = unRMap2 . metamorph @_ @r @c @(RMap (Compose f g)) @(RMap2 f g) @(Compose f g) Proxy doNil doUncons doCons . RMap   where     doNil _ = RMap2 empty     doUncons l (RMap r) = (r .! l, RMap $ unsafeRemove l r)@@ -342,7 +358,7 @@ -- | Convert from a record where the composition of two functors have been mapped -- over the types to one where the two functors are mapped individually one at a -- time over the types.-uncompose :: forall (f :: * -> *) g r . Forall r Unconstrained1+uncompose :: forall (f :: * -> *) (g :: * -> *) r . Forall r Unconstrained1           => Rec (Map (Compose f g) r) -> Rec (Map f (Map g r)) uncompose = uncompose' @Unconstrained1 @f @g @r @@ -352,7 +368,7 @@  -- | Zips together two records that have the same set of labels. zip :: forall r1 r2. Forall2 r1 r2 Unconstrained1 => Rec r1 -> Rec r2 -> Rec (Zip r1 r2)-zip r1 r2 = unRZipPair $ metamorph2 @r1 @r2 @Unconstrained1 @Rec @Rec @RZipPair @Identity @Identity Proxy Proxy doNil doUncons doCons r1 r2+zip r1 r2 = unRZipPair $ metamorph2 @_ @r1 @r2 @Unconstrained1 @Rec @Rec @RZipPair @Identity @Identity Proxy Proxy doNil doUncons doCons r1 r2   where     doNil _ _ = RZipPair empty     doUncons l r1 r2 = ((Identity $ r1 .! l, unsafeRemove l r1), (Identity $ r2 .! l, unsafeRemove l r2))@@ -389,7 +405,7 @@ -- the label at that value.  This function works over an 'Applicative'. fromLabelsA :: forall c f ρ. (Applicative f, Forall ρ c, AllUniqueLabels ρ)             => (forall l a. (KnownSymbol l, c a) => Label l -> f a) -> f (Rec ρ)-fromLabelsA mk = getCompose $ metamorph @ρ @c @(Const ()) @(Compose f Rec) @(Const ()) Proxy doNil doUncons doCons (Const ())+fromLabelsA mk = getCompose $ metamorph @_ @ρ @c @(Const ()) @(Compose f Rec) @(Const ()) Proxy doNil doUncons doCons (Const ())   where doNil _ = Compose $ pure empty         doUncons _ _ = (Const (), Const ())         doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)@@ -404,3 +420,79 @@                 \\ uniqueMap @g @ρ    where inner :: forall l a. (KnownSymbol l, IsA c g a) => Label l -> f a          inner l = case as @c @g @a of As -> f l++{--------------------------------------------------------------------+  Native data type compatibility+--------------------------------------------------------------------}+-- ToNative is shamelessly copied from+--   https://www.athiemann.net/2017/07/02/superrecord.html++-- $native+-- The 'toNative' and 'fromNative' functions allow one to convert between+-- 'Rec's and regular Haskell data types ("native" types) that have a single constructor and any+-- number of named fields with the same names and types as the 'Rec'.  That+-- said, they do not compose to form the identity because 'toNative' allows+-- fields to be dropped: a record with excess fields can still be transformed+-- to a native type, but when the native type is converted to a record, the+-- fields are exactly transformed.  Because of this, 'toNative' requires a type+-- application (although 'fromNative' does not).  The only requirement is that+-- the native Haskell data type be an instance of 'Generic'.+--+-- For example, consider the following simple data type:+--+-- >>> data Person = Person { name :: String, age :: Int} deriving (Generic, Show)+--+-- Then, we have the following:+--+-- >>> toNative @Person $ #name .== "Alice" .+ #age .== 7 .+ #hasDog .== True+-- Person {name = "Alice", age = 7}+-- >>> fromNative $ Person "Bob" 9+-- { age=9, name="Bob" }+++-- | Conversion helper to bring a record back into a Haskell type. Note that the+-- native Haskell type must be an instance of 'Generic'.+class ToNative a ρ where+  toNative' :: Rec ρ -> a x++instance ToNative cs ρ => ToNative (G.D1 m cs) ρ where+  toNative' xs = G.M1 $ toNative' xs++instance ToNative cs ρ => ToNative (G.C1 m cs) ρ where+  toNative' xs = G.M1 $ toNative' xs++instance (KnownSymbol name, ρ .! name ≈ t)+    => ToNative (G.S1 ('G.MetaSel ('Just name) p s l) (G.Rec0 t)) ρ where+  toNative' r = G.M1 $ G.K1 $ r .! (Label @name)++instance (ToNative l ρ, ToNative r ρ)+    => ToNative (l G.:*: r) ρ where+  toNative' r = toNative' r G.:*: toNative' r++-- | Convert a record to a native Haskell type.+toNative :: forall t ρ. (G.Generic t, ToNative (G.Rep t) ρ) => Rec ρ -> t+toNative = G.to . toNative'+++-- | Conversion helper to turn a Haskell record into a row-types extensible+-- record. Note that the native Haskell type must be an instance of 'Generic'.+class FromNative a ρ where+  fromNative' :: a x -> Rec ρ++instance FromNative cs ρ => FromNative (G.D1 m cs) ρ where+  fromNative' (G.M1 xs) = fromNative' xs++instance FromNative cs ρ => FromNative (G.C1 m cs) ρ where+  fromNative' (G.M1 xs) = fromNative' xs++instance (KnownSymbol name, ρ ≈ name .== t)+    => FromNative (G.S1 ('G.MetaSel ('Just name) p s l) (G.Rec0 t)) ρ where+  fromNative' (G.M1 (G.K1 x)) =  (Label @name) .== x++instance (FromNative l ρ₁, FromNative r ρ₂, ρ ≈ ρ₁ .+ ρ₂)+    => FromNative (l G.:*: r) ρ where+  fromNative' (x G.:*: y) = fromNative' @l @ρ₁ x .+ fromNative' @r @ρ₂ y++-- | Convert a Haskell record to a row-types Rec.+fromNative :: forall t ρ. (G.Generic t, FromNative (G.Rep t) ρ) => t -> Rec ρ+fromNative = fromNative' . G.from

@@ -78,7 +78,7 @@  instance (Forall r Eq, Forall r Ord) => Ord (Var r) where   compare :: Var r -> Var r -> Ordering-  compare x y = getConst $ metamorph' @r @Ord @(Product Var Var) @(Const Ordering) @(Const Ordering) Proxy doNil doUncons doCons (Pair x y)+  compare x y = getConst $ metamorph' @_ @r @Ord @(Product Var Var) @(Const Ordering) @(Const Ordering) Proxy doNil doUncons doCons (Pair x y)     where doNil (Pair x _) = impossible x           doUncons l (Pair r1 r2) = case (trial r1 l, trial r2 l) of             (Left a,  Left b)  -> Left $ Const $ compare a b@@ -89,7 +89,7 @@           doCons _ (Right (Const c)) = Const c  instance Forall r NFData => NFData (Var r) where-  rnf r = getConst $ metamorph' @r @NFData @Var @(Const ()) @Identity Proxy empty doUncons doCons r+  rnf r = getConst $ metamorph' @_ @r @NFData @Var @(Const ()) @Identity Proxy empty doUncons doCons r     where empty = const $ Const ()           doUncons l = left Identity . flip trial l           doCons _ x = deepseq x $ Const ()@@ -182,7 +182,7 @@  -- | A fold with labels eraseWithLabels :: forall c ρ s b. (Forall ρ c, IsString s) => (forall a. c a => a -> b) -> Var ρ -> (s,b)-eraseWithLabels f = getConst . metamorph' @ρ @c @Var @(Const (s,b)) @Identity Proxy impossible doUncons doCons+eraseWithLabels f = getConst . metamorph' @_ @ρ @c @Var @(Const (s,b)) @Identity Proxy impossible doUncons doCons   where doUncons l = left Identity . flip trial l         doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)                => Label ℓ -> Either (Identity τ) (Const (s,b) ('R ρ)) -> Const (s,b) ('R (ℓ :-> τ ': ρ))@@ -191,7 +191,7 @@  -- | A fold over two row type structures at once eraseZip :: forall c ρ b. Forall ρ c => (forall a. c a => a -> a -> b) -> Var ρ -> Var ρ -> Maybe b-eraseZip f x y = getConst $ metamorph' @ρ @c @(Product Var Var) @(Const (Maybe b)) @(Const (Maybe b)) Proxy doNil doUncons doCons (Pair x y)+eraseZip f x y = getConst $ metamorph' @_ @ρ @c @(Product Var Var) @(Const (Maybe b)) @(Const (Maybe b)) Proxy doNil doUncons doCons (Pair x y)   where doNil _ = Const Nothing         doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)                  => Label ℓ -> Product Var Var ('R (ℓ :-> τ ': ρ)) -> Either (Const (Maybe b) τ) (Product Var Var ('R ρ))@@ -209,7 +209,7 @@  -- | A function to map over a variant given a constraint. map :: forall c f r. Forall r c => (forall a. c a => a -> f a) -> Var r -> Var (Map f r)-map f = unVMap . metamorph' @r @c @Var @(VMap f) @Identity Proxy doNil doUncons doCons+map f = unVMap . metamorph' @_ @r @c @Var @(VMap f) @Identity Proxy doNil doUncons doCons   where     doNil = impossible     doUncons l = left Identity . flip trial l@@ -226,8 +226,8 @@ -- variant transformer to convert a variant of @f a@ values to a variant of @g a@ -- values.  If no constraint is needed, instantiate the first type argument with -- 'Unconstrained1'.-transform :: forall r c f g. Forall r c => (forall a. c a => f a -> g a) -> Var (Map f r) -> Var (Map g r)-transform f = unVMap . metamorph' @r @c @(VMap f) @(VMap g) @f Proxy doNil doUncons doCons . VMap+transform :: forall r c (f :: * -> *) (g :: * -> *). Forall r c => (forall a. c a => f a -> g a) -> Var (Map f r) -> Var (Map g r)+transform f = unVMap . metamorph' @_ @r @c @(VMap f) @(VMap g) @f Proxy doNil doUncons doCons . VMap   where     doNil = impossible . unVMap     doUncons l = right VMap . flip trial l . unVMap@@ -237,12 +237,12 @@     doCons _ (Right (VMap v)) = VMap $ unsafeInjectFront v  -- | A form of @transformC@ that doesn't have a constraint on @a@-transform' :: forall r f g . Forall r Unconstrained1 => (forall a. f a -> g a) -> Var (Map f r) -> Var (Map g r)+transform' :: forall r (f :: * -> *) (g :: * -> *) . Forall r Unconstrained1 => (forall a. f a -> g a) -> Var (Map f r) -> Var (Map g r) transform' = transform @r @Unconstrained1  -- | Applicative sequencing over a variant sequence :: forall f r. (Forall r Unconstrained1, Applicative f) => Var (Map f r) -> f (Var r)-sequence = getCompose . metamorph' @r @Unconstrained1 @(VMap f) @(Compose f Var) @f Proxy doNil doUncons doCons . VMap+sequence = getCompose . metamorph' @_ @r @Unconstrained1 @(VMap f) @(Compose f Var) @f Proxy doNil doUncons doCons . VMap   where     doNil (VMap x) = impossible x     doUncons l = right VMap . flip trial l . unVMap@@ -260,8 +260,8 @@  -- | Convert from a variant where two functors have been mapped over the types to -- one where the composition of the two functors is mapped over the types.-compose :: forall (f :: * -> *) g r . Forall r Unconstrained1 => Var (Map f (Map g r)) -> Var (Map (Compose f g) r)-compose = unVMap . metamorph' @r @Unconstrained1 @(VMap2 f g) @(VMap (Compose f g)) Proxy doNil doUncons doCons . VMap2+compose :: forall (f :: * -> *) (g :: * -> *) r . Forall r Unconstrained1 => Var (Map f (Map g r)) -> Var (Map (Compose f g) r)+compose = unVMap . metamorph' @_ @r @Unconstrained1 @(VMap2 f g) @(VMap (Compose f g)) Proxy doNil doUncons doCons . VMap2   where     doNil (VMap2 x) = impossible x     doUncons l = Compose +++ VMap2 <<< flip trial l . unVMap2@@ -271,8 +271,8 @@ -- | Convert from a variant where the composition of two functors have been mapped -- over the types to one where the two functors are mapped individually one at a -- time over the types.-uncompose :: forall (f :: * -> *) g r . Forall r Unconstrained1 => Var (Map (Compose f g) r) -> Var (Map f (Map g r))-uncompose = unVMap2 . metamorph' @r @Unconstrained1 @(VMap (Compose f g)) @(VMap2 f g) Proxy doNil doUncons doCons . VMap+uncompose :: forall (f :: * -> *) (g :: * -> *) r . Forall r Unconstrained1 => Var (Map (Compose f g) r) -> Var (Map f (Map g r))+uncompose = unVMap2 . metamorph' @_ @r @Unconstrained1 @(VMap (Compose f g)) @(VMap2 f g) Proxy doNil doUncons doCons . VMap   where     doNil (VMap x) = impossible x     doUncons l = right VMap . flip trial l . unVMap@@ -297,7 +297,7 @@ -- be the value in the variant. fromLabels :: forall c ρ f. (Alternative f, Forall ρ c, AllUniqueLabels ρ)            => (forall l a. (KnownSymbol l, c a) => Label l -> f a) -> f (Var ρ)-fromLabels mk = getCompose $ metamorph' @ρ @c @(Const ()) @(Compose f Var) @(Const ())+fromLabels mk = getCompose $ metamorph' @_ @ρ @c @(Const ()) @(Compose f Var) @(Const ())                                         Proxy doNil doUncons doCons (Const ())   where doNil _ = Compose $ empty         doUncons _ _ = Right $ Const ()@@ -306,4 +306,3 @@         doCons l (Left _) = Compose $ unsafeMakeVar l <$> mk l --This case should be impossible         doCons l (Right (Compose v)) = Compose $           unsafeMakeVar l <$> mk l <|> unsafeInjectFront <$> v-

@@ -66,7 +66,7 @@  If we show this at the repl, we see: λ> origin-{ x=0.0, y=0.0 }+ #x .== 0.0 .+ #y .== 0.0  Of course, as an extensible record, the order that we build it shouldn't matter, and indeed, it doesn't.  Consider the following variation:@@ -76,8 +76,8 @@  If we show this at the repl, we see: -λ> origin2-{ x=0.0, y=0.0 }+λ> origin'+ #x .== 0.0 .+ #y .== 0.0  Indeed, the two values are indistinguishable: @@ -136,7 +136,7 @@ We can see it work in practice:  λ> move origin 3 4-{ x=3.0, y=4.0 }+ #x .== 3.0 .+ #y .== 4.0 λ> distance (move origin 3 4) 5.0 λ> distance (move (named "2D" origin3D) 5 12)@@ -160,7 +160,7 @@ Regardless, with the type provided, it works exactly as expected:  λ> origin4-{ w=0.0, x=0.0, y=0.0, z=0.0 }+ #w .== 0.0 .+ #x .== 0.0 .+ #y .== 0.0 .+ #z .== 0.0  While we have added names or further fields, we can also choose to forget information in a record.  To remove a particular label, one can use the .-

@@ -1,5 +1,5 @@ Name:                row-types-Version:             0.2.2.0+Version:             0.2.3.0 License:             MIT License-file:        LICENSE Author:              Daniel Winograd-Cort, Matthew Farkas-Dyck