row-types (empty) → 0.2.0.0
raw patch · 13 files changed
+1753/−0 lines, 13 filesdep +basedep +criteriondep +deepseqsetup-changed
Dependencies added: base, criterion, deepseq, hashable, row-types, text, unordered-containers
Files
- CHANGELOG.md +3/−0
- Data/Row.hs +59/−0
- Data/Row/Internal.hs +422/−0
- Data/Row/Records.hs +378/−0
- Data/Row/Switch.hs +45/−0
- Data/Row/Variants.hs +299/−0
- Examples.lhs +390/−0
- LICENSE +7/−0
- NOTICE +15/−0
- README.md +16/−0
- Setup.hs +2/−0
- benchmarks/perf/Main.hs +33/−0
- row-types.cabal +84/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@++## 0.2.0.0 [2018-02-12]+- Initial Release
+ Data/Row.hs view
@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Row+--+-- This module includes a set of common functions for Records and Variants.+-- It includes:+--+-- * Common constructors, destructors, and querying functions+--+-- It specifically excludes:+--+-- * Functions that have the same name for Records and Variants (e.g. 'focus',+-- 'update', 'fromLabels', etc.)+--+-- * Common clashes with the standard Prelude or other modules (e.g. 'map',+-- 'sequence', 'zip', 'Map', etc.)+--+-- If these particular functions are needed, they should be brought in qualified+-- from one of the Data.Row.*** modules directly.+--+-----------------------------------------------------------------------------+++module Data.Row+ (+ -- * Types and constraints+ Label(..)+ , KnownSymbol, AllUniqueLabels, WellBehaved+ , Var, Rec, Row, Empty, type (≈)+ , HasType, Lacks, type (.\), type (.+)+ , Forall, Switch(..)+ -- * Record Construction+ , empty+ , type (.==), (.==), pattern (:==), unSingleton+ -- ** Restriction+ , type (.-), (.-)+ , restrict+ -- ** Query+ , type (.!), (.!)+ -- ** Disjoint union+ , (.+), Disjoint, pattern (:+)+ -- * Variant construction+ , pattern IsJust+ -- ** Restriction+ , diversify+ -- ** Destruction+ , impossible, trial, trial', multiTrial+ , type (.\\)+ -- * Labels+ , labels+ )+where++import Data.Row.Variants+import Data.Row.Records+import Data.Row.Switch+++
+ Data/Row/Internal.hs view
@@ -0,0 +1,422 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Row.Internal+--+-- This module implements the internals of open records and variants.+--+-----------------------------------------------------------------------------+++module Data.Row.Internal+ (+ -- * Rows+ Row(..)+ , Label(..)+ , KnownSymbol+ , LT(..)+ , Empty+ , HideType(..)+ -- * Row Operations+ , Extend, Modify, Rename+ , type (.\), type (.!), type (.-), type (.+), type (.\\), type (.==)+ , Lacks, HasType+ -- * Row Classes+ , Labels, labels+ , Forall(..), Forall2(..)+ , Unconstrained1+ -- * Helper functions+ , show'+ , toKey+ , type (≈)+ , WellBehaved, AllUniqueLabels, Zip, Map, Subset, Disjoint+ )+where++import Data.Functor.Const+import Data.Proxy+import Data.String (IsString (fromString))+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Type.Equality (type (==))++import GHC.Exts -- needed for constraints kinds+import GHC.OverloadedLabels+import GHC.TypeLits+import qualified GHC.TypeLits as TL+++++{--------------------------------------------------------------------+ Rows+--------------------------------------------------------------------}+-- | The kind of rows. This type is only used as a datakind. A row is a typelevel entity telling us+-- which symbols are associated with which types.+newtype Row a = R [LT a]+ -- ^ A row is a list of symbol-to-type pairs that should always be sorted+ -- lexically by the symbol.+ -- The constructor is exported here (because this is an internal module) but+ -- should not be exported elsewhere.++-- | The kind of elements of rows. Each element is a label and its associated type.+data LT a = Symbol :-> a+++-- | A label+data Label (s :: Symbol) = Label++instance KnownSymbol s => Show (Label s) where+ show = symbolVal++instance x ≈ y => IsLabel x (Label y) where+#if __GLASGOW_HASKELL__ >= 802+ fromLabel = Label+#else+ fromLabel _ = Label+#endif++-- | A helper function for showing labels+show' :: (IsString s, Show a) => a -> s+show' = fromString . show++-- | A helper function to turn a Label directly into 'Text'.+toKey :: forall s. KnownSymbol s => Label s -> Text+toKey = Text.pack . symbolVal++-- | Type level version of 'empty'+type Empty = R '[]++-- | Elements stored in a Row type are usually hidden.+data HideType where+ HideType :: a -> HideType++++{--------------------------------------------------------------------+ Row operations+--------------------------------------------------------------------}++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+ R r .\ l = LacksR l r r++-- | Type level Row extension+type family Extend (l :: Symbol) (a :: *) (r :: Row *) :: Row * 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+ Modify l a (R ρ) = R (ModifyR l a ρ)++-- | Type level row renaming+type family Rename (l :: Symbol) (l' :: Symbol) (r :: Row *) :: Row * where+ Rename l l' r = Extend l' (r .! l) (r .- l)++infixl 5 .!+-- | Type level label fetching+type family (r :: Row *) .! (t :: Symbol) :: * where+ R r .! l = Get l r++infixl 6 .-+-- | Type level Row element removal+type family (r :: Row *) .- (s :: Symbol) :: Row * where+ R r .- l = R (Remove l r)++infixl 6 .++-- | Type level Row append+type family (l :: Row *) .+ (r :: Row *) :: Row * 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+ R l .\\ R r = R (Diff l r)++{--------------------------------------------------------------------+ Syntactic sugar for record operations+--------------------------------------------------------------------}+-- | Alias for '.\'. It is a class rather than an alias, so that+-- it can be partially applied.+class Lacks (l :: Symbol) (r :: Row *)+instance (r .\ l) => Lacks l r+++-- | Alias for @(r .! l) ≈ a@. It is a class rather than an alias, so that+-- it can be partially applied.+class (r .! l ≈ a) => HasType l a r+instance (r .! l ≈ a) => HasType l a r++-- | A type level way to create a singleton Row.+infix 7 .==+type (l :: Symbol) .== (a :: *) = Extend l a Empty+++{--------------------------------------------------------------------+ Constrained record operations+--------------------------------------------------------------------}++-- | Proof that the given label is a valid candidate for the next step+-- in a metamorph fold, i.e. it's not in the list yet and, when sorted,+-- will be placed at the head.+type FoldStep ℓ τ ρ = ( Inject (ℓ :-> τ) ρ ≈ ℓ :-> τ ': ρ+ , R ρ .\ ℓ+ )++-- | 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+ -- | 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 :: * -> *).+ Proxy h+ -> (f Empty -> g Empty)+ -- ^ The way to transform the empty element+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ) => Label ℓ -> f ('R (ℓ :-> τ ': ρ)) -> (h τ, f ('R ρ)))+ -- ^ The unfold+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FoldStep ℓ τ ρ) => Label ℓ -> h τ -> g ('R ρ) -> g ('R (ℓ :-> τ ': ρ)))+ -- ^ The fold+ -> f r -- ^ The input structure+ -> g r++ -- | 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 :: * -> *).+ Proxy h+ -> (f Empty -> g Empty)+ -- ^ The way to transform the empty element+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ) => Label ℓ -> f ('R (ℓ :-> τ ': ρ)) -> Either (h τ) (f ('R ρ)))+ -- ^ The unfold+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FoldStep ℓ τ ρ) => Label ℓ -> Either (h τ) (g ('R ρ)) -> g ('R (ℓ :-> τ ': ρ)))+ -- ^ The fold+ -> f r -- ^ The input structure+ -> g r++instance Forall (R '[]) c where+ {-# INLINE metamorph #-}+ metamorph _ empty _ _ = empty+ {-# INLINE metamorph' #-}+ metamorph' _ empty _ _ = empty++instance (KnownSymbol ℓ, c τ, FoldStep ℓ τ ρ, Forall ('R ρ) c) => Forall ('R (ℓ :-> τ ': ρ)) c where+ metamorph :: forall (f :: Row * -> *) (g :: Row * -> *) (h :: * -> *).+ Proxy h+ -> (f Empty -> g Empty)+ -- ^ The way to transform the empty element+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ) => Label ℓ -> f ('R (ℓ :-> τ ': ρ)) -> (h τ, f ('R ρ)))+ -- ^ The unfold+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FoldStep ℓ τ ρ) => Label ℓ -> h τ -> g ('R ρ) -> g ('R (ℓ :-> τ ': ρ)))+ -- ^ The fold+ -> 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'+ where (t, r') = uncons Label r+ metamorph' :: forall (f :: Row * -> *) (g :: Row * -> *) (h :: * -> *).+ Proxy h+ -> (f Empty -> g Empty)+ -- ^ The way to transform the empty element+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ) => Label ℓ -> f ('R (ℓ :-> τ ': ρ)) -> Either (h τ) (f ('R ρ)))+ -- ^ The unfold+ -> (forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FoldStep ℓ τ ρ) => Label ℓ -> Either (h τ) (g ('R ρ)) -> g ('R (ℓ :-> τ ': ρ)))+ -- ^ The fold+ -> 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++-- | 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+ -- | 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' :: * -> *).+ Proxy f' -> Proxy g'+ -> (f Empty -> g Empty -> h Empty Empty)+ -> (forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ, c τ1, c τ2)+ => Label ℓ+ -> f ('R (ℓ :-> τ1 ': ρ1))+ -> g ('R (ℓ :-> τ2 ': ρ2))+ -> ((f' τ1, f ('R ρ1)), (g' τ2, g ('R ρ2))))+ -> (forall ℓ τ1 τ2 ρ1 ρ2. (KnownSymbol ℓ, c τ1, c τ2)+ => Label ℓ -> f' τ1 -> g' τ2 -> h ('R ρ1) ('R ρ2) -> h ('R (ℓ :-> τ1 ': ρ1)) ('R (ℓ :-> τ2 ': ρ2)))+ -> f r1 -> g r2 -> h r1 r2++instance Forall2 (R '[]) (R '[]) c where+ {-# INLINE metamorph2 #-}+ metamorph2 _ _ empty _ _ = empty++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'+ where ((t1, r1'), (t2, r2')) = uncons (Label @ℓ) r1 r2++-- | A null constraint+class Unconstrained+instance Unconstrained++-- | A null constraint of one argument+class Unconstrained1 a+instance Unconstrained1 a++-- | The labels in a Row.+type family Labels (r :: Row a) where+ Labels (R '[]) = '[]+ Labels (R (l :-> a ': xs)) = l ': Labels (R xs)++-- | 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 ())+ where doUncons _ _ = (Const (), Const ())+ doCons l _ (Const c) = Const $ show' l : c+++{--------------------------------------------------------------------+ Convenient type families and classes+--------------------------------------------------------------------}++-- | A convenient way to provide common, easy constraints+type WellBehaved ρ = (Forall ρ Unconstrained1, AllUniqueLabels ρ)++-- | Are all of the labels in this Row unique?+type family AllUniqueLabels (r :: Row *) :: Constraint where+ AllUniqueLabels (R r) = AllUniqueLabelsR r++type family AllUniqueLabelsR (r :: [LT *]) :: Constraint where+ AllUniqueLabelsR '[] = Unconstrained+ AllUniqueLabelsR '[l :-> a] = Unconstrained+ AllUniqueLabelsR (l :-> a ': l :-> b ': _) = TypeError+ (TL.Text "The label " :<>: ShowType l :<>: TL.Text " is not unique."+ :$$: TL.Text "It is assigned to both " :<>: ShowType a :<>: TL.Text " and " :<>: ShowType b)+ 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+ Subset (R r1) (R r2) = SubsetR r1 r2++type family SubsetR (r1 :: [LT *]) (r2 :: [LT *]) :: 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+ :<>: TL.Text " while the second does not.")+ SubsetR (l :-> a ': x) (l :-> a ': y) = SubsetR x y+ SubsetR (l :-> a ': x) (l :-> b ': y) =+ TypeError (TL.Text "One row-type is not a subset of the other."+ :$$: TL.Text "The first assigns the label " :<>: ShowType l :<>: TL.Text " to "+ :<>: ShowType a :<>: TL.Text " while the second assigns it to " :<>: ShowType b)+ SubsetR (hl :-> al ': tl) (hr :-> ar ': tr) =+ Ifte (hl <=.? hr)+ (TypeError (TL.Text "One row-type is not a subset of the other."+ :$$: TL.Text "The first assigns the label " :<>: ShowType hl :<>: TL.Text " to "+ :<>: ShowType al :<>: TL.Text " while the second has no assignment for it."))+ (SubsetR (hl :-> al ': tl) tr)++-- | A type synonym for disjointness.+type Disjoint l r = ( WellBehaved l+ , WellBehaved r+ , Subset l (l .+ r)+ , Subset r (l .+ r)+ , l .+ r .\\ l ≈ r+ , l .+ r .\\ r ≈ l)++-- | Map a type level function over a Row.+type family Map (f :: a -> b) (r :: Row a) :: Row b where+ Map f (R r) = R (MapR f r)++type family MapR (f :: a -> b) (r :: [LT a]) :: [LT b] where+ MapR f '[] = '[]+ MapR f (l :-> v ': t) = l :-> f v ': MapR f t++-- | Zips two rows together to create a Row of the pairs.+-- The two rows must have the same set of labels.+type family Zip (r1 :: Row *) (r2 :: Row *) where+ Zip (R r1) (R r2) = R (ZipR r1 r2)++type family ZipR (r1 :: [LT *]) (r2 :: [LT *]) where+ ZipR '[] '[] = '[]+ ZipR (l :-> t1 ': r1) (l :-> t2 ': r2) =+ l :-> (t1, t2) ': ZipR r1 r2+ ZipR (l :-> t1 ': r1) _ = 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.")+ 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+ 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 "+ :<>: ShowType t' :<>: TL.Text " and is now trying to be assigned the type "+ :<>: ShowType t :<>: TL.Text ".")+ Inject (l :-> t) (l' :-> t' ': x) =+ Ifte (l <=.? l')+ (l :-> t ': l' :-> t' ': x)+ (l' :-> t' ': Inject (l :-> t) x)++-- | Type level Row modification helper+type family ModifyR (l :: Symbol) (a :: *) (ρ :: [LT *]) :: [LT *] 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+ :<>: TL.Text ", but it does not appear in the row-type.")++type family Ifte (c :: Bool) (t :: k) (f :: k) where+ Ifte True t f = t+ Ifte False t f = f++type family Get (l :: Symbol) (r :: [LT *]) 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+ Remove l r = RemoveT l r r++type family RemoveT (l :: Symbol) (r :: [LT *]) (r_orig :: [LT *]) 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+ LacksR l '[] r = Unconstrained+ LacksR l (l :-> t ': x) r = TypeError (TL.Text "The label " :<>: ShowType l+ :<>: TL.Text " already exists in " :<>: ShowType r)+ LacksR l (p ': x) r = LacksR l x r++type family Merge (l :: [LT *]) (r :: [LT *]) where+ Merge '[] r = r+ Merge l '[] = l+ Merge (h :-> a ': tl) (h :-> a ': tr) =+ (h :-> a ': Merge tl tr)+ Merge (h :-> a ': tl) (h :-> b ': tr) =+ TypeError (TL.Text "The label " :<>: ShowType h :<>: TL.Text " has conflicting assignments."+ :$$: TL.Text "Its type is both " :<>: ShowType a :<>: TL.Text " and " :<>: ShowType b :<>: TL.Text ".")+ Merge (hl :-> al ': tl) (hr :-> ar ': tr) =+ Ifte (hl <=.? hr)+ (hl :-> al ': Merge tl (hr :-> ar ': tr))+ (hr :-> ar ': Merge (hl :-> al ': tl) tr)++-- | Returns the left list with all of the elements from the right list removed.+type family Diff (l :: [LT *]) (r :: [LT *]) where+ Diff '[] r = '[]+ Diff l '[] = l+ Diff (l :-> al ': tl) (l :-> al ': tr) = Diff tl tr+ Diff (hl :-> al ': tl) (hr :-> ar ': tr) =+ Ifte (hl <=.? hr)+ (hl :-> al ': Diff tl (hr :-> ar ': tr))+ (Diff (hl :-> al ': tl) tr)++-- | There doesn't seem to be a (<=.?) :: Symbol -> Symbol -> Bool,+-- so here it is in terms of other ghc-7.8 type functions+type a <=.? b = (CmpSymbol a b == 'LT)++-- | A lower fixity operator for type equality+infix 4 ≈+type a ≈ b = a ~ b
+ Data/Row/Records.hs view
@@ -0,0 +1,378 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Row.Records+--+-- This module implements extensible records using closed type famillies.+--+-- See Examples.hs for examples.+--+-- Lists of (label,type) pairs are kept sorted thereby ensuring+-- that { x = 0, y = 0 } and { y = 0, x = 0 } have the same type.+--+-- In this way we can implement standard type classes such as Show, Eq, Ord and Bounded+-- for open records, given that all the elements of the open record satify the constraint.+--+-----------------------------------------------------------------------------+++module Data.Row.Records+ (+ -- * Types and constraints+ Label(..)+ , KnownSymbol, AllUniqueLabels, WellBehaved+ , Rec, Row, Empty, type (≈)+ -- * Construction+ , empty+ , type (.==), (.==), pattern (:==), unSingleton+ , default', defaultA+ , fromLabels, fromLabelsA+ -- ** Extension+ , extend, Extend, Lacks, type (.\)+ -- ** Restriction+ , type (.-), (.-)+ , restrict, split+ -- ** Modification+ , update, focus, multifocus, Modify, rename, Rename+ -- * Query+ , HasType, type (.!), (.!)+ -- * Combine+ -- ** Disjoint union+ , type (.+), (.+), Disjoint, pattern (:+)+ -- * Row operations+ -- ** Map+ , Map, map, map'+ , transform, transform'+ -- ** Fold+ , Forall, erase, eraseWithLabels, eraseZip, eraseToHashMap+ -- ** Zip+ , Zip, zip+ -- ** Sequence+ , sequence+ -- ** Compose+ -- $compose+ , compose, uncompose+ -- ** Labels+ , labels+ -- ** UNSAFE operations+ , unsafeRemove, unsafeInjectFront+ )+where++import Prelude hiding (map, sequence, zip)++import Control.DeepSeq (NFData(..), deepseq)++import Data.Functor.Compose+import Data.Functor.Const+import Data.Functor.Identity+import Data.Functor.Product+import Data.Hashable+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as M+import Data.List hiding (map, zip)+import qualified Data.List as L+import Data.Proxy+import Data.String (IsString)+import Data.Text (Text)++import GHC.TypeLits++import Unsafe.Coerce++import Data.Row.Internal+++{--------------------------------------------------------------------+ Open records+--------------------------------------------------------------------}+-- | A record with row r.+newtype Rec (r :: Row *) where+ OR :: HashMap Text HideType -> Rec r++instance Forall r Show => Show (Rec r) where+ show r = "{ " ++ intercalate ", " binds ++ " }"+ where binds = (\ (x, y) -> x ++ "=" ++ y) <$> eraseWithLabels @Show show r++instance Forall r Eq => Eq (Rec r) where+ r == r' = and $ eraseZip @Eq (==) r r'++instance (Forall r Eq, Forall r Ord) => Ord (Rec r) where+ compare m m' = cmp $ eraseZip @Ord compare m m'+ where cmp l | [] <- l' = EQ+ | a : _ <- l' = a+ where l' = dropWhile (== EQ) l++instance (Forall r Bounded, AllUniqueLabels r) => Bounded (Rec r) where+ minBound = default' @Bounded minBound+ 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+ where empty = const $ Const ()+ doUncons l r = (Identity $ r .! l, unsafeRemove l r)+ doCons _ x r = deepseq x $ deepseq r $ Const ()++-- | The empty record+empty :: Rec Empty+empty = OR M.empty++-- | The singleton record+infix 7 .==+(.==) :: KnownSymbol l => Label l -> a -> Rec (l .== a)+l .== a = extend l a empty++-- | A pattern for the singleton record; can be used to both destruct a record+-- when in a pattern position or construct one in an expression position.+{-# COMPLETE (:==) #-}+infix 7 :==+pattern (:==) :: forall l a. KnownSymbol l => Label l -> a -> Rec (l .== a)+pattern l :== a <- (unSingleton @l @a -> (l, a)) where+ (:==) l a = l .== a++-- | Turns a singleton record into a pair of the label and value.+unSingleton :: forall l a. KnownSymbol l => Rec (l .== a) -> (Label l, a)+unSingleton r = (l, r .! l) where l = Label @l++{--------------------------------------------------------------------+ Basic record operations+--------------------------------------------------------------------}+++-- | Record extension. The row may already contain the label,+-- in which case the origin value can be obtained after restriction ('.-') with+-- the label.+extend :: forall a l r. KnownSymbol l => Label l -> a -> Rec r -> Rec (Extend l a r)+extend (toKey -> l) a (OR m) = OR $ M.insert l (HideType a) m++-- | Update the value associated with the label.+update :: KnownSymbol l => Label l -> a -> Rec r -> Rec r+update (toKey -> l) a (OR m) = OR $ M.adjust f l m where f = const (HideType a)++-- | Focus on the value associated with the label.+focus :: (Functor f, KnownSymbol l) => Label l -> (r .! l -> f a) -> Rec r -> f (Rec (Modify l a r))+focus (toKey -> l) f (OR m) = case m M.! l of+ HideType x -> OR . flip (M.insert l) m . HideType <$> f (unsafeCoerce x)++-- | Focus on a sub-record+multifocus :: forall u v r f.+ ( Functor f+ , Disjoint u r+ , Disjoint v r)+ => (Rec u -> f (Rec v)) -> Rec (u .+ r) -> f (Rec (v .+ r))+multifocus f (u :+ r) = (.+ r) <$> f u++-- | Rename a label.+rename :: (KnownSymbol l, KnownSymbol l') => Label l -> Label l' -> Rec r -> Rec (Rename l l' r)+rename (toKey -> l) (toKey -> l') (OR m) = OR $ M.insert l' (m M.! l) $ M.delete l m++-- | Record selection+(.!) :: KnownSymbol l => Rec r -> Label l -> r .! l+OR m .! (toKey -> a) = case m M.! a of+ HideType x -> unsafeCoerce x++infixl 6 .-+-- | Record restriction. Remove the label l from the record.+(.-) :: KnownSymbol l => Rec r -> Label l -> Rec (r .- l)+-- OR m .- _ = OR m+OR m .- (toKey -> a) = OR $ M.delete a m++-- | Record disjoint union (commutative)+infixl 6 .++(.+) :: Rec l -> Rec r -> Rec (l .+ r)+OR l .+ OR r = OR $ M.unionWith (error "Impossible") l r+++-- | A pattern version of record union, for use in pattern matching.+{-# COMPLETE (:+) #-}+infixl 6 :++pattern (:+) :: forall l r. Disjoint l r => Rec l -> Rec r -> Rec (l .+ r)+pattern l :+ r <- (split @l -> (l, r)) where+ (:+) l r = l .+ r++-- | Split a record into two sub-records.+split :: forall s r. (Forall s Unconstrained1, Subset s r)+ => Rec r -> (Rec s, Rec (r .\\ s))+split (OR m) = (OR $ M.intersection m labelMap, OR $ M.difference m labelMap)+ where labelMap = M.fromList $ L.zip (labels @s @Unconstrained1) (repeat ())++-- | Arbitrary record restriction. Turn a record into a subset of itself.+restrict :: forall r r'. (Forall r Unconstrained1, Subset r r') => Rec r' -> Rec r+restrict = fst . split++-- | Removes a label from the record but does not remove the underlying value.+--+-- This is faster than regular record removal ('.-') but should only be used when+-- either: the record will never be merged with another record again, or a new+-- value will soon be placed into the record at this label (as in, an 'update'+-- that is split over two commands).+--+-- If the resulting record is then merged (with '.+') with another record that+-- contains a value at that label, an "impossible" error will occur.+unsafeRemove :: KnownSymbol l => Label l -> Rec r -> Rec (r .- l)+unsafeRemove _ (OR m) = OR m+++{--------------------------------------------------------------------+ Folds and maps+--------------------------------------------------------------------}+-- An easier type synonym for a pair where both elements are the same type.+type IPair = Product Identity Identity++-- Construct an IPair.+iPair :: τ -> τ -> IPair τ+iPair = (. Identity) . Pair . Identity++-- Destruct an IPair. Easily used with ViewPatterns.+unIPair :: IPair τ -> (τ, τ)+unIPair (Pair (Identity x) (Identity y)) = (x,y)+++-- | A standard fold+erase :: forall c ρ b. Forall ρ c => (forall a. c a => a -> b) -> Rec ρ -> [b]+erase f = fmap (snd @String) . eraseWithLabels @c f++-- | 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+ where doNil _ = Const []+ doUncons l r = (Identity $ r .! l, unsafeRemove l r)+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Identity τ -> Const [(s,b)] ('R ρ) -> Const [(s,b)] ('R (ℓ :-> τ ': ρ))+ doCons l (Identity x) (Const c) = Const $ (show' l, f x) : c++-- | 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)+ 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)+ doCons :: forall ℓ τ ρ. c τ+ => Label ℓ -> IPair τ -> Const [b] ('R ρ) -> Const [b] ('R (ℓ :-> τ ': ρ))+ doCons _ (unIPair -> x) (Const c) = Const $ uncurry f x : c++-- | Turns a record into a 'HashMap' from values representing the labels to+-- the values of the record.+eraseToHashMap :: forall c r s b. (IsString s, Eq s, Hashable s, Forall r c) =>+ (forall a . c a => a -> b) -> Rec r -> HashMap s b+eraseToHashMap f r = M.fromList $ eraseWithLabels @c f r++-- | RMap is used internally as a type level lambda for defining record maps.+newtype RMap (f :: * -> *) (ρ :: Row *) = RMap { unRMap :: Rec (Map f ρ) }+newtype RMap2 (f :: * -> *) (g :: * -> *) (ρ :: Row *) = RMap2 { unRMap2 :: Rec (Map f (Map g ρ)) }++-- | 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+ where+ doNil _ = RMap empty+ doUncons l r = (Identity $ r .! l, unsafeRemove l r)+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Identity τ -> RMap f ('R ρ) -> RMap f ('R (ℓ :-> τ ': ρ))+ doCons l (Identity v) (RMap r) = RMap (unsafeInjectFront l (f v) r)++-- | A function to map over a record given no constraint.+map' :: forall f r. Forall r Unconstrained1 => (forall a. a -> f a) -> Rec r -> Rec (Map f r)+map' = map @Unconstrained1++-- | Lifts a natrual transformation over a record. In other words, it acts as a+-- 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+ where+ doNil _ = RMap empty+ doUncons l (RMap r) = (r .! l, RMap $ unsafeRemove l r)+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> f τ -> RMap g ('R ρ) -> RMap g ('R (ℓ :-> τ ': ρ))+ 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' = transform @Unconstrained1 @r++-- | Applicative sequencing over a record+sequence :: forall f r. (Forall r Unconstrained1, Applicative f) => Rec (Map f r) -> f (Rec r)+sequence = getCompose . metamorph @r @Unconstrained1 @(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)+ doCons l fv (Compose fr) = Compose $ unsafeInjectFront l <$> fv <*> fr++-- $compose+-- We can easily convert between mapping two functors over the types of a row+-- and mapping the composition of the two functors. The following two functions+-- perform this composition with the gaurantee that:+--+-- >>> compose . uncompose = id+--+-- >>> uncompose . compose = id++-- | 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 => Rec (Map f (Map g r)) -> Rec (Map (Compose f g) r)+compose = unRMap . metamorph @r @Unconstrained1 @(RMap2 f g) @(RMap (Compose f g)) Proxy doNil doUncons doCons . RMap2+ where+ doNil _ = RMap empty+ doUncons l (RMap2 r) = (Compose $ r .! l, RMap2 $ unsafeRemove l r)+ doCons l v (RMap r) = RMap $ unsafeInjectFront l v r++-- | 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 => Rec (Map (Compose f g) r) -> Rec (Map f (Map g r))+uncompose = unRMap2 . metamorph @r @Unconstrained1 @(RMap (Compose f g)) @(RMap2 f g) Proxy doNil doUncons doCons . RMap+ where+ doNil _ = RMap2 empty+ doUncons l (RMap r) = (r .! l, RMap $ unsafeRemove l r)+ doCons l (Compose v) (RMap2 r) = RMap2 $ unsafeInjectFront l v r++-- | RZipPair is used internally as a type level lambda for zipping records.+newtype RZipPair (ρ1 :: Row *) (ρ2 :: Row *) = RZipPair { unRZipPair :: Rec (Zip ρ1 ρ2) }++-- | 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+ where+ doNil _ _ = RZipPair empty+ doUncons l r1 r2 = ((Identity $ r1 .! l, unsafeRemove l r1), (Identity $ r2 .! l, unsafeRemove l r2))+ doCons l (Identity v1) (Identity v2) (RZipPair r) = RZipPair $ unsafeInjectFront l (v1, v2) r++-- | A helper function for unsafely adding an element to the front of a record.+-- This can cause the resulting record to be malformed, for instance, if the record+-- already contains labels that are lexicographically before the given label.+-- Realistically, this function should only be used when writing calls to 'metamorph'.+unsafeInjectFront :: KnownSymbol l => Label l -> a -> Rec (R r) -> Rec (R (l :-> a ': r))+unsafeInjectFront (toKey -> a) b (OR m) = OR $ M.insert a (HideType b) m+++{--------------------------------------------------------------------+ Record initialization+--------------------------------------------------------------------}++-- | Initialize a record with a default value at each label.+default' :: forall c ρ. (Forall ρ c, AllUniqueLabels ρ) => (forall a. c a => a) -> Rec ρ+default' v = runIdentity $ defaultA @c $ pure v++-- | Initialize a record with a default value at each label; works over an 'Applicative'.+defaultA :: forall c f ρ. (Applicative f, Forall ρ c, AllUniqueLabels ρ)+ => (forall a. c a => f a) -> f (Rec ρ)+defaultA v = fromLabelsA @c $ pure v++-- | Initialize a record, where each value is determined by the given function over+-- the label at that value.+fromLabels :: forall c ρ. (Forall ρ c, AllUniqueLabels ρ)+ => (forall l a. (KnownSymbol l, c a) => Label l -> a) -> Rec ρ+fromLabels f = runIdentity $ fromLabelsA @c $ (pure .) f++-- | Initialize a record, where each value is determined by the given function over+-- 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 ())+ where doNil _ = Compose $ pure empty+ doUncons _ _ = (Const (), Const ())+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Const () τ -> Compose f Rec ('R ρ) -> Compose f Rec ('R (ℓ :-> τ ': ρ))+ doCons l _ (Compose r) = Compose $ unsafeInjectFront l <$> mk l <*> r+
+ Data/Row/Switch.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FunctionalDependencies #-}+-----------------------------------------------------------------------------+-- |+-- Module: Data.Row.Switch+--+-- This module provides the ability to discharge a polymorphic variant using+-- a record that has matching fields.+--+-----------------------------------------------------------------------------+++module Data.Row.Switch+ (+ Switch(..)+ )+where++import Data.Row.Internal+import Data.Row.Records+import Data.Row.Variants++++-- | A 'Var' and a 'Rec' can combine if their rows line up properly.+class Switch (v :: Row *) (r :: Row *) x | v x -> r, r x -> v where+ {-# MINIMAL switch | caseon #-}+ -- | Given a Variant and a Record of functions from each possible value+ -- of the variant to a single output type, apply the correct+ -- function to the value in the variant.+ switch :: Var v -> Rec r -> x+ switch = flip caseon+ -- | The same as @switch@ but with the argument order reversed+ caseon :: Rec r -> Var v -> x+ caseon = flip switch+++instance Switch (R '[]) (R '[]) x where+ switch = const . impossible++instance (KnownSymbol l, Switch (R v) (R r) b)+ => Switch (R (l :-> a ': v)) (R (l :-> (a -> b) ': r)) b where+ switch v r = case trial v l of+ Left x -> (r .! l) x+ Right v -> switch v (unsafeRemove l r)+ where l = Label @l
+ Data/Row/Variants.hs view
@@ -0,0 +1,299 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Row.Variants+--+-- This module implements extensible variants using closed type families.+--+-----------------------------------------------------------------------------+++module Data.Row.Variants+ (+ -- * Types and constraints+ Label(..)+ , KnownSymbol, AllUniqueLabels, WellBehaved+ , Var, Row, Empty, type (≈)+ -- * Construction+ , HasType, pattern IsJust, singleton+ , fromLabels+ -- ** Extension+ , type (.\), Lacks, diversify, type (.+)+ -- ** Modification+ , update, focus, Modify, rename, Rename+ -- * Destruction+ , impossible, trial, trial', multiTrial, view+ -- ** Types for destruction+ , type (.!), type (.-), type (.\\), type (.==)+ -- * Row operations+ -- ** Map+ , Map, map, map', transform, transform'+ -- ** Fold+ , Forall, erase, eraseWithLabels, eraseZip+ -- ** Sequence+ , sequence+ -- ** Compose+ -- $compose+ , compose, uncompose+ -- ** labels+ , labels+ -- ** UNSAFE operations+ , unsafeMakeVar, unsafeInjectFront+ )+where++import Prelude hiding (zip, map, sequence)++import Control.Applicative+import Control.Arrow ((<<<), (+++), left, right)+import Control.DeepSeq (NFData(..), deepseq)++import Data.Functor.Compose+import Data.Functor.Identity+import Data.Functor.Product+import Data.Maybe (fromMaybe)+import Data.Proxy+import Data.String (IsString)+import Data.Text (Text)++import GHC.TypeLits++import Unsafe.Coerce++import Data.Row.Internal++{--------------------------------------------------------------------+ Polymorphic Variants+--------------------------------------------------------------------}++-- | The variant type.+data Var (r :: Row *) where+ OneOf :: Text -> HideType -> Var r++instance Forall r Show => Show (Var r) where+ show v = (\ (x, y) -> "{" ++ x ++ "=" ++ y ++ "}") $ eraseWithLabels @Show show v++instance Forall r Eq => Eq (Var r) where+ r == r' = fromMaybe False $ eraseZip @Eq (==) r r'++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)+ 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+ (Left _, Right _) -> Left $ Const LT+ (Right _, Left _) -> Left $ Const GT+ (Right x, Right y) -> Right $ Pair x y+ doCons _ (Left (Const c)) = Const c+ 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+ where empty = const $ Const ()+ doUncons l = left Identity . flip trial l+ doCons _ x = deepseq x $ Const ()+++{--------------------------------------------------------------------+ Basic Operations+--------------------------------------------------------------------}++-- | An unsafe way to make a Variant. This function does not guarantee that+-- the labels are all unique.+unsafeMakeVar :: forall r l. KnownSymbol l => Label l -> r .! l -> Var r+unsafeMakeVar (toKey -> l) = OneOf l . HideType++-- | A Variant with no options is uninhabited.+impossible :: Var Empty -> a+impossible _ = error "Impossible! Somehow, a variant of nothing was produced."++-- | A quick constructor to create a singleton variant.+singleton :: KnownSymbol l => Label l -> a -> Var (l .== a)+singleton = IsJust++-- | A pattern for variants; can be used to both destruct a variant+-- when in a pattern position or construct one in an expression position.+pattern IsJust :: forall l r. (AllUniqueLabels r, KnownSymbol l) => Label l -> r .! l -> Var r+pattern IsJust l a <- (unSingleton @l -> (l, Just a)) where+ IsJust l a = unsafeMakeVar l a++unSingleton :: forall l r. KnownSymbol l => Var r -> (Label l, Maybe (r .! l))+unSingleton v = (l, view l v) where l = Label @l++-- | Make the variant arbitrarily more diverse.+diversify :: forall r' r. AllUniqueLabels (r .+ r') => Var r -> Var (r .+ r')+diversify = unsafeCoerce -- (OneOf l x) = OneOf l x++-- | If the variant exists at the given label, update it to the given value.+-- Otherwise, do nothing.+update :: KnownSymbol l => Label l -> a -> Var r -> Var r+update (toKey -> l') a (OneOf l x) = OneOf l $ if l == l' then HideType a else x++-- | If the variant exists at the given label, focus on the value associated with it.+-- Otherwise, do nothing.+focus :: (Applicative f, KnownSymbol l) => Label l -> (r .! l -> f a) -> Var r -> f (Var (Modify l a r))+focus (toKey -> l') f (OneOf l (HideType x)) = if l == l' then (OneOf l . HideType) <$> f (unsafeCoerce x) else pure (OneOf l (HideType x))++-- | Rename the given label.+rename :: (KnownSymbol l, KnownSymbol l') => Label l -> Label l' -> Var r -> Var (Rename l l' r)+rename (toKey -> l1) (toKey -> l2) (OneOf l x) = OneOf (if l == l1 then l2 else l) x++-- | Convert a variant into either the value at the given label or a variant without+-- that label. This is the basic variant destructor.+trial :: KnownSymbol l => Var r -> Label l -> Either (r .! l) (Var (r .- l))+trial (OneOf l (HideType x)) (toKey -> l') = if l == l' then Left (unsafeCoerce x) else Right (OneOf l (HideType x))++-- | A version of 'trial' that ignores the leftover variant.+trial' :: KnownSymbol l => Var r -> Label l -> Maybe (r .! l)+trial' = (either Just (const Nothing) .) . trial++-- | A trial over multiple types+multiTrial :: forall x y. (AllUniqueLabels x, Forall (y .\\ x) Unconstrained1) => Var y -> Either (Var x) (Var (y .\\ x))+multiTrial (OneOf l x) = if l `elem` labels @(y .\\ x) @Unconstrained1 then Right (OneOf l x) else Left (OneOf l x)++-- | A convenient function for using view patterns when dispatching variants.+-- For example:+--+-- @+-- myShow :: Var ("y" '::= String :| "x" '::= Int :| Empty) -> String+-- myShow (view x -> Just n) = "Int of "++show n+-- myShow (view y -> Just s) = "String of "++s @+view :: KnownSymbol l => Label l -> Var r -> Maybe (r .! l)+view = flip trial'+++{--------------------------------------------------------------------+ Folds and maps+--------------------------------------------------------------------}++-- | A standard fold+erase :: forall c ρ b. Forall ρ c => (forall a. c a => a -> b) -> Var ρ -> b+erase f = snd @String . eraseWithLabels @c f++-- | 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+ where doUncons l = left Identity . flip trial l+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Either (Identity τ) (Const (s,b) ('R ρ)) -> Const (s,b) ('R (ℓ :-> τ ': ρ))+ doCons l (Left (Identity x)) = Const (show' l, f x)+ doCons _ (Right (Const c)) = Const c++-- | 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)+ where doNil _ = Const Nothing+ doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Product Var Var ('R (ℓ :-> τ ': ρ)) -> Either (Const (Maybe b) τ) (Product Var Var ('R ρ))+ doUncons l (Pair r1 r2) = case (trial r1 l, trial r2 l) of+ (Left a, Left b) -> Left $ Const $ Just $ f a b+ (Right x, Right y) -> Right $ Pair x y+ _ -> Left $ Const Nothing+ doCons _ (Left (Const c)) = Const c+ doCons _ (Right (Const c)) = Const c+++-- | VMap is used internally as a type level lambda for defining variant maps.+newtype VMap (f :: * -> *) (ρ :: Row *) = VMap { unVMap :: Var (Map f ρ) }+newtype VMap2 (f :: * -> *) (g :: * -> *) (ρ :: Row *) = VMap2 { unVMap2 :: Var (Map f (Map g ρ)) }++-- | 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+ where+ doNil = impossible+ doUncons l = left Identity . flip trial l+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Either (Identity τ) (VMap f ('R ρ)) -> VMap f ('R (ℓ :-> τ ': ρ))+ doCons l (Left (Identity x)) = VMap $ unsafeMakeVar l $ f x+ doCons _ (Right (VMap v)) = VMap $ unsafeInjectFront v++-- | A function to map over a variant given no constraint.+map' :: forall f r. Forall r Unconstrained1 => (forall a. a -> f a) -> Var r -> Var (Map f r)+map' = map @Unconstrained1++-- | Lifts a natrual transformation over a variant. In other words, it acts as a+-- 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+ where+ doNil = impossible . unVMap+ doUncons l = right VMap . flip trial l . unVMap+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Either (f τ) (VMap g ('R ρ)) -> VMap g ('R (ℓ :-> τ ': ρ))+ doCons l (Left x) = VMap $ unsafeMakeVar l $ f x+ 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' = 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+ where+ doNil (VMap x) = impossible x+ doUncons l = right VMap . flip trial l . unVMap+ doCons l (Left fx) = Compose $ unsafeMakeVar l <$> fx+ doCons _ (Right (Compose v)) = Compose $ unsafeInjectFront <$> v++-- $compose+-- We can easily convert between mapping two functors over the types of a row+-- and mapping the composition of the two functors. The following two functions+-- perform this composition with the gaurantee that:+--+-- >>> compose . uncompose = id+--+-- >>> uncompose . compose = id++-- | 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+ where+ doNil (VMap2 x) = impossible x+ doUncons l = Compose +++ VMap2 <<< flip trial l . unVMap2+ doCons l (Left x) = VMap $ unsafeMakeVar l x+ doCons _ (Right (VMap v)) = VMap $ unsafeInjectFront v++-- | 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+ where+ doNil (VMap x) = impossible x+ doUncons l = right VMap . flip trial l . unVMap+ doCons l (Left (Compose x)) = VMap2 $ unsafeMakeVar l x+ doCons _ (Right (VMap2 v)) = VMap2 $ unsafeInjectFront v+++{--------------------------------------------------------------------+ Variant initialization+--------------------------------------------------------------------}++-- | A helper function for unsafely adding an element to the front of a variant.+-- This can cause the type of the resulting variant to be malformed, for instance,+-- if the variant already contains labels that are lexicographically before the+-- given label. Realistically, this function should only be used when writing+-- calls to 'metamorph'.+unsafeInjectFront :: forall l a r. KnownSymbol l => Var (R r) -> Var (R (l :-> a ': r))+unsafeInjectFront = unsafeCoerce++-- | Initialize a variant from a producer function that accepts labels. If this+-- function returns more than one possibility, then one is chosen arbitrarily to+-- 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 ())+ Proxy doNil doUncons doCons (Const ())+ where doNil _ = Compose $ empty+ doUncons _ _ = Right $ Const ()+ doCons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ)+ => Label ℓ -> Either (Const () τ) (Compose f Var ('R ρ)) -> Compose f Var ('R (ℓ :-> τ ': ρ))+ 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+
+ Examples.lhs view
@@ -0,0 +1,390 @@+> {-# LANGUAGE OverloadedLabels #-}+> module Examples where+>+> import Data.Row+> import qualified Data.Row.Records as Rec+> import qualified Data.Row.Variants as Var++In this example file, we will explore how to create and use records and variants.++--------------------------------------------------------------------------------+ LABELS+--------------------------------------------------------------------------------++To begin, we will briefly discuss creating labels -- their use will follow.++The most basic way to create a label is through construction with a type signature:++ x = Label :: Label "x"++With the above definition, x is a label for the field x. Using type applications,+this can be shortened to:++ x = Label @"x"++And with OverloadedLabels, one can just write:++ #x++We will use the OverloadedLabels notation in these examples.++--------------------------------------------------------------------------------+ LENS+--------------------------------------------------------------------------------++Records and variants play nicely with the lens library if we additionally import+Data.Row.Lens from the row-types-lens "orphan instance" library. Each overloaded+label is also a Lens for a record and a Traversal for variants. Thus, .! can be+replaced with ^. and trial can be made infix with ^?. Additionally, update+can be made infix:++update #x v r === r & #x .~ v++And because of the power of lens, it's easy to make modifications rather than+just update:++update #x (f $ r .! #x) r === r & #x %~ f++Lens is not included with row-types by default, but using it can make row-types+much friendlier.++--------------------------------------------------------------------------------+ RECORDS+--------------------------------------------------------------------------------++With some labels defined, let's begin with records. To start, let's create a+record representing the Cartesian coordinates of the origin. To do this,+we use the .== operator to initialize values in a record, and we separate each+initialized value with the .+ operator.Notice that the value level code uses the+same operators as the type level code.++> origin :: Rec ("x" .== Double .+ "y" .== Double )+> origin = #x .== 0 .+ #y .== 0++Note that, although we wrote the type explicitly, GHC has no problem inferring+it exactly.++If we show this at the repl, we see:+λ> origin+{ 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:++> origin' :: Rec ("y" .== Double .+ "x" .== Double)+> origin' = #y .== 0 .+ #x .== 0++If we show this at the repl, we see:++λ> origin2+{ x=0.0, y=0.0 }++Indeed, the two values are indistinguishable:++λ> origin == origin'+True++Now, let's expand upon our record. Why stop at two dimensions when we can make+a record in three dimensions.++> origin3D = #z .== 0.0 .+ origin++Once again, the type is inferred for us, and the record is exactly as expected.++In fact, we can do this generally. The following function takes a name and a+record and adds the "name" field to that record with the given name.++> named :: r .\ "name" => a -> Rec r -> Rec ("name" .== a .+ r)+> named s r = #name .== s .+ r++Note that we require that the record we are naming must not have a "name" field+already. Overlapping labels within a single record/variant is strictly forbidden.++Let's say we want to get the values out of the record. Simple selection is achieved+with the .! operator, like so:++λ> origin .! #x+0.0++and we can use this to write whatever we want. Here is a function for calculating+Euclidean distance from the origin to a point:++> distance :: (Floating t, r .! "y" ≈ t, r .! "x" ≈ t) => Rec r -> t+> distance p = sqrt $ p .! #x * p .! #x + p .! #y * p .! #y++Once again, the type of distance is entirely inferrable, but we write it here for+convenience. This works exactly as expected:++λ> distance origin+0.0+λ> distance origin3D+0.0+λ> distance (named "2D" origin)+0.0++Of course, that wasn't very interesting when our only points are at the origin+already. We could make new records representing new points, but instead, let's+write a function to move the points we have:++> move :: (Num (r .! "x"), Num (r .! "y"))+> => Rec r -> r .! "x" -> r .! "y" -> Rec r+> move p dx dy = Rec.update #x (p .! #x + dx) $+> Rec.update #y (p .! #y + dy) p++Here, we're using the Rec.update operator to update the value at the label x by+adding dx to it, and then we do the same for y.+We can see it work in practice:++λ> move origin 3 4+{ x=3.0, y=4.0 }+λ> distance (move origin 3 4)+5.0+λ> distance (move (named "2D" origin3D) 5 12)+13.0++Note that if we were using row-types-lens and the lens library, we could write+move as:++move p dx dy = p & #x +~ dx & #y +~ dy++So far, we created an origin point in 2d and then one in 3d, but what if we are+adventurous mathematicians who want to have points in a space with some arbitrary+number of dimensions. We could write out each of the 0s necessary, but there's+an easier way to initialize a record:++> origin4 :: Rec ("x" .== Double .+ "y" .== Double .+ "z" .== Double .+ "w" .== Double)+> origin4 = Rec.default' @Num 0++Finally, we have come to a case where GHC cannot infer the type signature, and how+could it! The type is providing crucial information about the shape of the record.+Regardless, with the type provided, it works exactly as expected:++λ> origin4+{ 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 .-+operator, like so:++> unName :: HasType "name" a r => Rec r -> Rec (r .- "name")+> unName r = r .- #name++For larger changes, it is easier to use the restrict function. The following+function will take a record that contains both an x and y coordinate and remove+the rest of the fields from it.++> get2D :: (r ≈ "x" .== Double .+ "y" .== Double, Disjoint r rest)+> => Rec (r .+ rest)+> -> Rec r+> get2D r = restrict r++GHC is a little finicky about the type operators and constraints -- indeed, this+type signature will fail to type check if the parentheses around+ "x" .== Double .+ "y" .== Double+in the argument are missing. Of course, a type signature is not necessary when+using type applications, and the function can instead be written as:++> get2D' r = restrict @("x" .== Double .+ "y" .== Double) r++with no trouble. Yet another altnerative is to match directly on the values desired+using the :== and :+ record patterns:++> get2D'' :: (r ≈ "x" .== Double .+ "y" .== Double, Disjoint r rest)+> => Rec (r .+ rest)+> -> Rec r+> get2D'' ((Label :: Label "x") :== n1 :+ (Label :: Label "y") :== n2 :+ _)+> = #x .== n1 .+ #y .== n2++(Note that overloaded labels cannot be used in the patterns, so the notation is+unfortunately bloated by types. Also, the type operators are left associated,+so the "_" must go on the right, and the type signature is unforunately necessary.)++All three of the get2D functions behave the same.++--------------------------------------------------------------------------------+ VARIANTS+--------------------------------------------------------------------------------+Let's move on from records to variants. In many ways, variants are quite similar,+as might be expected given that variants are dual to records. The types look+almost the same, and some of the operators are shared as well. However,+construction and destruction are obviously different.++Creating a variant can be done with IsJust:++> v,v' :: Var ("y" .== String .+ "x" .== Integer)+> v = IsJust #x 1+> v' = IsJust #y "Foo"++Here, the type is necessary to specify what concrete type the variant is (when+using AllowAmbiguousTypes, the type is not always needed, but it would be needed+to e.g. show the variant). In the simple case of a variant of just one type,+the simpler singleton function can be used:++> v2 = Var.singleton #x 1++Now, the type can be easily derived by GHC. We can show variants as easily as+records:++λ> v+{x=1}+λ> v'+{y="Foo"}+λ> v2+{x=1}++Once created, a variant can be expanded by using type applications and the+diversify function.++> v3 = diversify @("y" .== String) v2+> v4 = diversify @("y" .== String .+ "z" .== Double) v2++λ> :t v4+v4 :: Var ('R '["x" ':-> Integer, "y" ':-> String, "z" ':-> Double])+λ> v == v3+True++Doing the above equality test does raise the question of how equality works on+variants. For instance, v2 and v3 both look the same when you show them, and they+both have the same value inside, but can we test them for equality? Indeed, we can't,+precisely because their types are different: it is a type error to even try to+check whether they're equal:++λ> v2 == v3+error:+ • Couldn't match type ‘'["y" ':-> [Char]]’ with ‘'[]’+ Expected type: Var ('R '["x" ':-> Integer])+ Actual type: Var ('R '["x" ':-> Integer] .+ ("y" .== String))+ • In the second argument of ‘(==)’, namely ‘v3’+ In the expression: v2 == v3+ In an equation for ‘it’: it = v2 == v3++This may look a little scary, but it's actually a pretty useful message. Essentially,+it's expecting a variant that can only be an Integer at label "x", but it found one+that could also be a String at label "y". So, comparing v2 and v3 is not allowed,+but since v3 now has the same labels as v1, that comparison is fine:++λ> v == v3+True+λ> v == IsJust #x 3+False+λ> v == v'+False+λ> v == IsJust #y "fail"+False++(Also note here that using IsJust without a type signature is fine because the correct+type can be easily inferred due to v's type.)++What can you do with a variant? The only way to really use one is to get the value+out, and to do that, you must trial it:++λ> trial v #x+Left 1+λ> trial v #y+Right {x=1}+λ> trial v' #x+Right {y="Foo"}+λ> trial v' #y+Left "Foo"++If trialing at a label l succeeds, then it provides a Left value of the value at l.+If not, it provides a Right value of the variant with this label removed---since the+trial failed, we now can be sure that the value is not from l.++For ease of use in view patterns, Variants also exposes the view function.+(If using lens, this can be replaced with preview.) With it, we can write a+function like this:++> myShow :: (r .! "y" ≈ String, Show (r .! "x")) => Var r -> String+> myShow (Var.view #x -> Just n) = "Int of "++show n+> myShow (Var.view #y -> Just s) = "String of "++s+> myShow _ = "Unknown"++λ> myShow v+"Int of 1"+λ> myShow v'+"String of Foo"+λ> myShow (just #z 3 :: Var ("y" .== String .+ "x" .== Integer .+ "z" .== Double))+"Unknown"++This can also be achieved with the IsJust pattern synonym in much the same way:++> myShow' :: (WellBehaved r, r .! "y" ≈ String, Show (r .! "x")) => Var r -> String+> myShow' (IsJust (Label :: Label "x") n) = "Int of "++show n+> myShow' (IsJust (Label :: Label "y") s) = "String of "++s+> myShow' _ = "Unknown"++In either case, the type signature is once again totally derivable.++There are two minor annoyances with this. First, it's fairly common to want to define+a function like myShow to be exhaustive in the variant's cases, but to do this,+you must manually provide a type signature:++> myShowRestricted :: Var ("y" .== String .+ "x" .== Integer) -> String+> myShowRestricted (Var.view #x -> Just n) = "Int of "++show n+> myShowRestricted (Var.view #y -> Just s) = "String of "++s+> myShowRestricted _ = error "Unreachable"++The second blemish can be seen in this restricted version of myShow. Even though+we know from the type that we've covered all the posibilities of the variant, GHC+will generate a "non-exhaustive pattern match" warning without the final line.+(This is true for the pattern synonym version too.)++One way to avoid this problem is to use switch. The switch operator takes a variant+and a record such that for each label that the variant has, the record has a function+at that label that consumes the value the variant has and produces a value in a+common type. Essentially, switch "applies" the variant to the record to produce+an output value.++> --myShowRestricted' :: Var ("y" .== String .+ "x" .== Integer) -> String+> myShowRestricted' v = switch v $+> #x .== (\n -> "Int of "++show n)+> .+ #y .== (\s -> "String of "++s)++This version of myShow needs neither a type signature (it is inferred exactly) nor+a default "unreachable" case. However, we no longer have the benefit of Haskell's+standard pattern matching.++++A more powerful version of trial is multiTrial, which tests for multiple labels+at once. With this, you can wholesale change the type of the variant to any (valid)+variant type you would like. Of course, there needs to be a recourse if the variant+you provide is not expressible in the type you want, so multiTrial returns an Either+of the type you want or a Variant of the leftovers. Consider the examples:++λ> :t multiTrial @("x" .== Double .+ "y" .== String) v+multiTrial @("x" .== Double .+ "y" .== String) v+ :: Either+ (Var ('R '["x" ':-> Double, "y" ':-> String]))+ (Var ('R '["x" ':-> Integer]))+λ> multiTrial @("x" .== Double .+ "y" .== String) v+Right {x=1}++λ> :t multiTrial @("x" .== Double .+ "y" .== String) v'+multiTrial @("x" .== Double .+ "y" .== String) v'+ :: Either+ (Var ('R '["x" ':-> Double, "y" ':-> String]))+ (Var ('R '["x" ':-> Integer]))+λ> multiTrial @("x" .== Double .+ "y" .== String) v'+Left {y="Foo"}++Thus, multiTrial can be used not only to arbitrarily split apart a variant, but+also to change unused label associations (in this case, we changed the variant+from one where "x" is an Integer to one where it's a Double).+++Here are two functions you can define over variants. The type constraints are a little+ugly (the type equalities are necessary but annoying).++> also :: Disjoint xs ys+> => (Var xs -> a)+> -> (Var ys -> a)+> -> Var (xs .+ ys) -> a+> also f1 f2 e = case multiTrial e of+> Left e' -> f1 e'+> Right e' -> f2 e'++> joinVarLists :: forall x y. (WellBehaved (x .+ y), x .+ y ≈ y .+ x)+> => [Var x] -> [Var y] -> [Var (x .+ y)]+> joinVarLists xs ys = map (diversify @y) xs ++ map (diversify @x) ys
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2017 Target Brands, Inc.++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ NOTICE view
@@ -0,0 +1,15 @@+This software package includes open source components, each of which is subject to its respective license as listed below:++-------------------------------------------------------------------------------+- CTRex (commit 5cf771e3c6650351b2aad08d5bd8e94a87ec326d) https://github.com/atzeus/CTRex/blob/master/LICENSE++Copyright (c) 2015, Atze van der Ploeg+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the Atze van der Ploeg nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+ README.md view
@@ -0,0 +1,16 @@+Row-Types+=======++Row-types is a library of open records and variants for Haskell using closed+type families and type literals (among other things...).+See [Examples.lhs](https://raw.githubusercontent.com/target/row-types/master/Examples.lhs)+for an overview of how this library can be used.++This work is a branch from CTRex [1,2] with other inspiration from data-diverse [3].+My thanks to the authors and contributors of those libraries!++[1] https://wiki.haskell.org/CTRex++[2] https://hackage.haskell.org/package/CTRex/docs/Data-OpenRecords.html++[3] https://hackage.haskell.org/package/data-diverse
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/perf/Main.hs view
@@ -0,0 +1,33 @@+module Main (main) where++import Criterion.Main++import Data.String++import Data.Row.Records++type FiveRecord a = "a" .== a .+ "b" .== a .+ "c" .== a .+ "d" .== a .+ "e" .== a++main :: IO ()+main =+ defaultMain+ [ bgroup "Record Construction"+ [ bench "simple 1" $ nf (#a .==) ()+ , bench "simple 5" $ nf id $ #a .== () .+ #b .== () .+ #c .== () .+ #d .== () .+ #e .== ()+ , bench "simple 10" $ nf id $ #a .== () .+ #b .== () .+ #c .== () .+ #d .== () .+ #e .== ()+ .+ #f .== () .+ #g .== () .+ #h .== () .+ #i .== () .+ #j .== ()+ , bench "reverse 5" $ nf id $ #e .== () .+ #d .== () .+ #c .== () .+ #b .== () .+ #a .== ()+ , bench "append 3 3" $ nf (uncurry (.+)) (#a .== () .+ #b .== () .+ #c .== (), #d .== () .+ #e .== () .+ #f .== ())+ , bench "append 5 1" $ nf (uncurry (.+)) (#a .== () .+ #b .== () .+ #c .== () .+ #d .== () .+ #e .== (), #f .== ())+ , bench "append 1 5" $ nf (uncurry (.+)) (#a .== (), #b .== () .+ #c .== () .+ #d .== () .+ #e .== () .+ #f .== ())+ , bench "default 5" $ nf id $ default' @Num @(FiveRecord Double) 0+ , bench "recordFromLabels 5" $ nf id $ fromLabels @IsString @(FiveRecord String) (fromString . show)+ ]+ , bgroup "Record Access"+ [ bench "get 1 of 5" $ nf (.! #a) $ #a .== () .+ #b .== () .+ #c .== () .+ #d .== () .+ #e .== ()+ , bench "get 5 of 5" $ nf (.! #e) $ #a .== () .+ #b .== () .+ #c .== () .+ #d .== () .+ #e .== ()+ ]+ , bgroup "Record Metamorphosis"+ [ bench "erase" $ nf (erase @Show show) $ #a .== () .+ #b .== () .+ #c .== () .+ #d .== () .+ #e .== ()+ ]+ ]
+ row-types.cabal view
@@ -0,0 +1,84 @@+Name: row-types+Version: 0.2.0.0+License: MIT+License-file: LICENSE+Author: Daniel Winograd-Cort, Matthew Farkas-Dyck+Maintainer: daniel.winograd-cort@target.com, matthew.farkas-dyck@target.com+Build-Type: Simple+Cabal-Version: >=1.8+Category: Data, Data Structures+Synopsis: Open Records and Variants+Description:+ This package uses closed type families and type literals to implement open+ records and variants.+ The core is based off of the <https://hackage.haskell.org/package/CTRex CTRex>+ package, but it additionally includes polymorphic variants and a number of+ additional functions. That said, it is not a proper superset of CTRex as it+ specifically forbids records from having more than one element of the same+ label.++extra-source-files:+ Examples.lhs+ README.md+ CHANGELOG.md+ LICENSE+ NOTICE++Library+ Build-Depends: base >= 2 && < 5,+ deepseq >= 1.4,+ hashable >= 1.2,+ unordered-containers >= 0.2,+ text+ Exposed-modules: Data.Row+ , Data.Row.Internal+ , Data.Row.Records+ , Data.Row.Variants+ , Data.Row.Switch+ ghc-options: -W+ other-modules:+ Extensions: AllowAmbiguousTypes,+ ConstraintKinds,+ DataKinds,+ EmptyDataDecls,+ FlexibleContexts,+ FlexibleInstances,+ GADTs,+ InstanceSigs,+ KindSignatures,+ MultiParamTypeClasses,+ OverloadedLabels,+ PatternGuards,+ PatternSynonyms,+ PolyKinds,+ RankNTypes,+ ScopedTypeVariables,+ TypeApplications,+ TypeFamilies,+ TypeOperators,+ TupleSections,+ ViewPatterns,+ UndecidableInstances++benchmark perf+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ benchmarks/perf+ ghc-options: -W+ build-depends: base >= 2 && < 6+ , row-types+ , deepseq >= 1.4+ , criterion >= 1.1+ Extensions: AllowAmbiguousTypes,+ DataKinds,+ OverloadedLabels,+ RankNTypes,+ ScopedTypeVariables,+ TypeApplications,+ TypeFamilies,+ TypeOperators++source-repository head+ type: git+ location: https://github.com/target/row-types/