HList 0.3.2.0 → 0.3.4.0
raw patch · 16 files changed
+180/−148 lines, 16 filesdep +taggeddep ~base
Dependencies added: tagged
Dependency ranges changed: base
Files
- ChangeLog +5/−0
- Data/HList/Data.hs +4/−4
- Data/HList/FakePrelude.hs +4/−2
- Data/HList/FakePrelude/Proxy.hs +0/−23
- Data/HList/HList.hs +31/−17
- Data/HList/HListPrelude.hs +3/−2
- Data/HList/Keyword.hs +10/−10
- Data/HList/Labelable.hs +2/−2
- Data/HList/Record.hs +61/−64
- Data/HList/RecordPuns.hs +48/−12
- Data/HList/TIP.hs +2/−2
- Data/HList/Variant.hs +2/−2
- HList.cabal +3/−3
- examples/MainGhcGeneric1.hs +3/−3
- examples/TIPTransform.hs +1/−1
- examples/TIPTransformM.hs +1/−1
ChangeLog view
@@ -1,3 +1,8 @@+20 Feb 2014+ Release 0.3.4+ RecordPuns add ( ) syntax+ Use the tagged package: this removes LVPair and lowercase proxy.+ 03 Feb 2014 Release 0.3.2.0 Relax hspec dependency
Data/HList/Data.hs view
@@ -181,7 +181,7 @@ instance RecordLabelsStr '[] where recordLabelsStr _ = [] instance (RecordLabelsStr xs,- ShowLabel x) => RecordLabelsStr (LVPair x t ': xs) where+ ShowLabel x) => RecordLabelsStr (Tagged x t ': xs) where recordLabelsStr _ = showLabel (undefined :: Label x) : recordLabelsStr (undefined :: Record xs) @@ -216,7 +216,7 @@ deriving instance Typeable Record deriving instance Typeable HList deriving instance Typeable HListFlat-deriving instance Typeable LVPair+-- deriving instance Typeable Tagged type TypeablePolyK (a :: k) = (Typeable a) #else@@ -228,12 +228,12 @@ typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "Record") [ tyConList (typeRepsList x) ] -instance ShowLabel sy => Typeable1 (LVPair sy) where+instance ShowLabel sy => Typeable1 (Tagged sy) where typeOf1 _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Data" (showLabel (undefined :: Label sy))) [] -instance (ShowLabel sy, Typeable x) => Typeable (LVPair sy x) where+instance (ShowLabel sy, Typeable x) => Typeable (Tagged sy x) where typeOf _ = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (undefined :: Label sy))) [mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "=") [],
Data/HList/FakePrelude.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverlappingInstances #-}+-- just for the proxy {- | The HList library@@ -9,11 +11,11 @@ module Data.HList.FakePrelude (module Data.HList.FakePrelude,- module Data.HList.FakePrelude.Proxy) where+ module Data.Proxy) where +import Data.Proxy import GHC.Prim (Constraint) import GHC.TypeLits-import Data.HList.FakePrelude.Proxy -- -------------------------------------------------------------------------- -- * A heterogeneous apply operator
− Data/HList/FakePrelude/Proxy.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE CPP #-}--{- | Injection from algebraic kinds to *--Algebraic kinds like Nat are not populated and we can't use -values of type Nat as function arguments. In contrast, we can use-(undefined :: Proxy Z) as an argument, as a value proxy.-data Proxy (tp :: k) :: *--re-exports 'Data.Typeable.Proxy' if it exists--}-module Data.HList.FakePrelude.Proxy (Proxy, proxy) where--#if MIN_VERSION_base(4,7,0)-import Data.Typeable (Proxy(..))-#else--data Proxy tp -#endif--proxy :: Proxy tp-proxy = undefined-
Data/HList/HList.hs view
@@ -96,7 +96,7 @@ hTail (HCons _ l) = l -- | Length-type family HLength (x :: [*]) :: HNat+type family HLength (x :: [k]) :: HNat type instance HLength '[] = HZero type instance HLength (x ': xs) = HSucc (HLength xs) @@ -109,10 +109,10 @@ (.*.) = HCons instance HAppend (HList l1) (HList l2) where- type HAppendR (HList l1) (HList l2) = HList (HAppendList l1 l2) hAppend = hAppendList+type instance HAppendR (HList l1) (HList l2) = HList (HAppendList l1 l2) -type family HAppendList (l1 :: [*]) (l2 :: [*]) :: [*]+type family HAppendList (l1 :: [k]) (l2 :: [k]) :: [k] type instance HAppendList '[] l = l type instance HAppendList (e ': l) l' = e ': HAppendList l l' @@ -171,7 +171,7 @@ -- * Reversing HLists -- Append the reversed l1 to l2-type family HRevApp (l1 :: [*]) (l2 :: [*]) :: [*]+type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k] type instance HRevApp '[] l = l type instance HRevApp (e ': l) l' = HRevApp l (e ': l') @@ -352,18 +352,22 @@ -- * replicate -class HReplicate (n :: HNat) e where- type HReplicateR n e :: [*]+class (HLength (HReplicateR n e) ~ n) =>+ HReplicate (n :: HNat) e where hReplicate :: Proxy n -> e -> HList (HReplicateR n e) instance HReplicate HZero e where- type HReplicateR HZero e = '[] hReplicate _ _ = HNil instance HReplicate n e => HReplicate (HSucc n) e where- type HReplicateR (HSucc n) e = e ': HReplicateR n e hReplicate n e = e `HCons` hReplicate (hPred n) e +-- | would be associated with 'HReplicate' except we want+-- it to work with `e` of any kind, not just `*` that you can+-- put into a HList. An \"inverse\" of 'HLength'+type family HReplicateR (n :: HNat) (e :: k) :: [k]+type instance HReplicateR HZero e = '[]+type instance HReplicateR (HSucc n) e = e ': HReplicateR n e -- * concat @@ -467,27 +471,37 @@ applyAB (HMap f) = hMapAux f type HMapCxt f as bs as' bs' = (HMapAux f as' bs', as ~ HList as', bs ~ HList bs',- SameLength as' bs', SameLength bs' as')+ SameLength as' bs') -- | Ensure two lists have the same length. We do case analysis on the -- first one (hence the type must be known to the type checker). -- In contrast, the second list may be a type variable.-class SameLength es1 es2-instance (es2 ~ '[]) => SameLength '[] es2-instance (SameLength xs ys, es2 ~ (y ': ys)) => SameLength (x ': xs) es2+class SameLength' (es1 :: [k]) (es2 :: [m])+instance (es2 ~ '[]) => SameLength' '[] es2+instance (SameLength' xs ys, es2 ~ (y ': ys)) => SameLength' (x ': xs) es2 +{- | symmetrical version of 'SameLength''. Written as a class instead of + > type SameLength a b = (SameLength' a b, SameLength' b a) +since ghc expands type synonyms, but not classes (and it seems to have the same+result) +-}+class (SameLength' x y, SameLength' y x) =>+ SameLength (x :: [k]) (y :: [m])+instance (SameLength' x y, SameLength' y x) => SameLength x y+++ class HMapAux f (l :: [*]) (r :: [*]) where- hMapAux :: (SameLength l r, SameLength r l) => f -> HList l -> HList r+ hMapAux :: SameLength l r => f -> HList l -> HList r instance HMapAux f '[] '[] where hMapAux _ _ = HNil -instance (ApplyAB f e e', HMapAux f l l',- SameLength l l', SameLength l' l)+instance (ApplyAB f e e', HMapAux f l l', SameLength l l') => HMapAux f (e ': l) (e' ': l') where hMapAux f (HCons x l) = applyAB f x `HCons` hMapAux f l @@ -551,7 +565,7 @@ <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018784.html> -} -class (Applicative m, SameLength a b, SameLength b a) => HSequence m a b | a -> b, m b -> a where+class (Applicative m, SameLength a b) => HSequence m a b | a -> b, m b -> a where hSequence :: HList a -> m (HList b) {- ^ @@ -814,7 +828,7 @@ => HTMember e (e' ': l) b'' hTMember :: HTMember e l b => e -> HList l -> Proxy b-hTMember _ _ = proxy+hTMember _ _ = Proxy -- * Intersection based on HTMember
Data/HList/HListPrelude.hs view
@@ -24,11 +24,12 @@ -- subType :: SubType l l' => l -> l' -> () -- subType _ _ = () --- poly-kinded class HAppend l1 l2 where- type HAppendR l1 l2 hAppend :: l1 -> l2 -> HAppendR l1 l2 +-- | poly-kinded, but 'hAppend' only works in cases where the kind variable+-- `k` is `*`+type family HAppendR (l1::k) (l2::k) :: k -- class HMember e1 l (b :: Bool) | e1 l -> b -- One occurrence and nothing is left
Data/HList/Keyword.hs view
@@ -66,7 +66,6 @@ import Data.HList.HListPrelude import Data.HList.HList import Data.HList.Record-import Data.HList.RecordPuns {- $setup @@ -368,7 +367,7 @@ instance (HEq kw kw' flag, KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r) => KWApply (kw ->a->f') (kw' ': a' ': tail) r where- kwapply = kwapply' (proxy :: Proxy flag)+ kwapply = kwapply' (Proxy :: Proxy flag) class KWApply' flag f arg_values r where kwapply':: Proxy flag -> f -> HList arg_values -> r@@ -429,7 +428,7 @@ instance (IsKeyFN r rflag, KW' rflag f arg_desc arg_def r) => KW f arg_desc arg_def r where- kwdo = kw' (proxy ::Proxy rflag)+ kwdo = kw' (Proxy ::Proxy rflag) class KW' rflag f arg_desc arg_def r where kw' :: Proxy rflag -> f -> arg_desc -> HList arg_def -> r@@ -479,7 +478,7 @@ instance (HEq kw kw' flag, KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r) => KWMerge' kw (kw' ': etc) atail arg_values arg_def f r where- kwmerge' = kwmerge'' (undefined:: Proxy flag)+ kwmerge' = kwmerge'' (Proxy :: Proxy flag) class KWMerge'' (flag :: Bool) kw (list :: [*]) atail arg_values arg_def f r where@@ -557,10 +556,10 @@ kw (HCons f arg_def) = kwdo f rfk arg_def :: r where rfk = reflect_fk f :: akws -data LVPairToKW = LVPairToKW-instance (x ~ LVPair l v, y ~ HList '[Label l, v]) =>- ApplyAB LVPairToKW x y where- applyAB _ (LVPair v) = hBuild Label v+data TaggedToKW = TaggedToKW+instance (x ~ Tagged l v, y ~ HList '[Label l, v]) =>+ ApplyAB TaggedToKW x y where+ applyAB _ (Tagged v) = hBuild Label v {- | convert a 'Record' into a list that can supply@@ -569,6 +568,7 @@ A bit of setup: >>> :set -XQuasiQuotes+>>> import Data.HList.RecordPuns >>> let f (_ :: Label "a") a (_ :: Label "b") b () = a `div` b @@ -581,10 +581,10 @@ -}-recToKW :: forall a b. (HMapAux LVPairToKW a b, SameLength a b,+recToKW :: forall a b. (HMapAux TaggedToKW a b, SameLength a b, SameLength b a, HConcat b) => Record a -> HList (HConcatR b)-recToKW (Record r) = hConcat (hMap LVPairToKW r :: HList b)+recToKW (Record r) = hConcat (hMap TaggedToKW r :: HList b) {- $originalIntro
Data/HList/Labelable.hs view
@@ -82,8 +82,8 @@ HasField x (Record t) b, HFind x (RecordLabels t) n, HFind x (RecordLabels s) n,- HUpdateAtHNat n (LVPair x b) s,- t ~ HUpdateAtHNatR n (LVPair x b) s)+ HUpdateAtHNat n (Tagged x b) s,+ t ~ HUpdateAtHNatR n (Tagged x b) s) => Labelable x (->) f s t a b where hLens' lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab))
Data/HList/Record.hs view
@@ -34,9 +34,7 @@ -- ** Labels -- $labels- LVPair(..),- labelLVPair,- newLVPair,+ module Data.Tagged, (.=.), (.-.), -- ** Record@@ -129,7 +127,9 @@ HRLabelSet', HRearrange(hRearrange2), HRearrange'(hRearrange2'),- UnionSymRec'(..)+ UnionSymRec'(..),+ labelLVPair,+ newLVPair, ) where @@ -137,6 +137,8 @@ import Data.HList.HListPrelude import Data.HList.HList import Data.HList.HArray++import Data.Tagged -- imports for doctest/examples import Data.HList.Label6 ()@@ -157,21 +159,16 @@ -- its value, and the record, at run-time, is indistinguishable from -- the HList of field values. At run-time, all information about the -- labels is erased.---- | Field of label l with value type v--- Polykinded with respect to l: label may be a symbol, a nat, etc.-newtype LVPair l v = LVPair { valueLVPair :: v } deriving Eq+--+-- The type from "Data.Tagged" is used. -- | Label accessor-labelLVPair :: LVPair l v -> Label l-labelLVPair = undefined+labelLVPair :: Tagged l v -> Label l+labelLVPair _ = Label -newLVPair :: Label l -> v -> LVPair l v-newLVPair _ = LVPair+newLVPair :: Label l -> v -> Tagged l v+newLVPair _ = Tagged --- stolen by typeable---infixr 4 :=:---type l :=: v = LVPair l v infixr 4 .=.@@ -186,7 +183,7 @@ Record{x="v1",y='2'} -}-(.=.) :: Label l -> v -> LVPair l v+(.=.) :: Label l -> v -> Tagged l v l .=. v = newLVPair l v @@ -212,11 +209,11 @@ instance HRLabelSet '[x] instance ( HEq l1 l2 leq , HRLabelSet' l1 l2 leq r- ) => HRLabelSet (LVPair l1 v1 ': LVPair l2 v2 ': r)+ ) => HRLabelSet (Tagged l1 v1 ': Tagged l2 v2 ': r) class HRLabelSet' l1 l2 (leq::Bool) (r :: [*])-instance ( HRLabelSet (LVPair l2 () ': r)- , HRLabelSet (LVPair l1 () ': r)+instance ( HRLabelSet (Tagged l2 () ': r)+ , HRLabelSet (Tagged l1 () ': r) ) => HRLabelSet' l1 l2 False r instance ( Fail (DuplicatedLabel l1) ) => HRLabelSet' l1 l2 True r @@ -244,10 +241,10 @@ type family RecordLabels (r :: [*]) :: [k] type instance RecordLabels '[] = '[]-type instance RecordLabels (LVPair l v ': r) = l ': RecordLabels r+type instance RecordLabels (Tagged l v ': r) = l ': RecordLabels r recordLabels :: Record r -> Proxy (RecordLabels r)-recordLabels = undefined+recordLabels _ = Proxy -- | Construct the HList of values of the record.@@ -258,9 +255,9 @@ instance RecordValues '[] where type RecordValuesR '[] = '[] recordValues' _ = HNil-instance RecordValues r=> RecordValues (LVPair l v ': r) where- type RecordValuesR (LVPair l v ': r) = v ': RecordValuesR r- recordValues' (HCons (LVPair v) r) = HCons v (recordValues' r)+instance RecordValues r=> RecordValues (Tagged l v ': r) where+ type RecordValuesR (Tagged l v ': r) = v ': RecordValuesR r+ recordValues' (HCons (Tagged v) r) = HCons v (recordValues' r) recordValues :: RecordValues r => Record r -> HList (RecordValuesR r) recordValues (Record r) = recordValues' r@@ -272,7 +269,7 @@ type instance LabelsOf (Label l ': r) = l ': LabelsOf r hLabels :: HList l -> Proxy (LabelsOf l)-hLabels = undefined+hLabels _ = Proxy -- -------------------------------------------------------------------------- @@ -293,8 +290,8 @@ , Show v , ShowComponents r )- => ShowComponents (LVPair l v ': r) where- showComponents comma (HCons f@(LVPair v) r)+ => ShowComponents (Tagged l v ': r) where+ showComponents comma (HCons f@(Tagged v) r) = comma ++ showLabel ((labelLVPair f) :: Label l) ++ "="@@ -308,9 +305,9 @@ -- Extension -instance HRLabelSet (LVPair l v ': r) - => HExtend (LVPair (l :: k) v) (Record r) where- type HExtendR (LVPair l v) (Record r) = Record (LVPair l v ': r)+instance HRLabelSet (Tagged l v ': r) + => HExtend (Tagged (l :: k) v) (Record r) where+ type HExtendR (Tagged l v) (Record r) = Record (Tagged l v ': r) f .*. (Record r) = mkRecord (HCons f r) @@ -333,9 +330,9 @@ instance (HRLabelSet (HAppendList r1 r2), HAppend (HList r1) (HList r2)) => HAppend (Record r1) (Record r2) where- type HAppendR (Record r1) (Record r2) = Record (HAppendList r1 r2) hAppend (Record r) (Record r') = mkRecord (hAppend r r') +type instance HAppendR (Record r1) (Record r2) = Record (HAppendList r1 r2) -- -------------------------------------------------------------------------- -- Lookup@@ -364,17 +361,17 @@ -instance (HEq l l1 b, HasField' b l (LVPair l1 v1 ': r) v)- => HasField l (Record (LVPair l1 v1 ': r)) v where+instance (HEq l l1 b, HasField' b l (Tagged l1 v1 ': r) v)+ => HasField l (Record (Tagged l1 v1 ': r)) v where hLookupByLabel l (Record r) =- hLookupByLabel' (undefined::Proxy b) l r+ hLookupByLabel' (Proxy::Proxy b) l r class HasField' (b::Bool) (l :: k) (r::[*]) v | b l r -> v where hLookupByLabel':: Proxy b -> Label l -> HList r -> v -instance HasField' True l (LVPair l v ': r) v where- hLookupByLabel' _ _ (HCons (LVPair v) _) = v+instance HasField' True l (Tagged l v ': r) v where+ hLookupByLabel' _ _ (HCons (Tagged v) _) = v instance HasField l (Record r) v => HasField' False l (fld ': r) v where hLookupByLabel' _ l (HCons _ r) = hLookupByLabel l (Record r) @@ -424,7 +421,7 @@ (H2ProjectByLabels '[l] t t1 t2) => Label l -> Record t -> Record t2 hDeleteAtLabel _ (Record r) = - Record $ snd $ h2projectByLabels (undefined::Proxy '[l]) r+ Record $ snd $ h2projectByLabels (Proxy::Proxy '[l]) r infixl 2 .-. {-|@@ -460,10 +457,10 @@ -- | 'hUpdateAtLabel' @label value record@ hUpdateAtLabel :: forall (r :: [*]) (l :: k) (n::HNat) (v :: *). - (HFind l (RecordLabels r) n, HUpdateAtHNat n (LVPair l v) r) =>- Label l -> v -> Record r -> Record (HUpdateAtHNatR n (LVPair l v) r)+ (HFind l (RecordLabels r) n, HUpdateAtHNat n (Tagged l v) r) =>+ Label l -> v -> Record r -> Record (HUpdateAtHNatR n (Tagged l v) r) hUpdateAtLabel l v (Record r) = - Record (hUpdateAtHNat (undefined::Proxy n) (newLVPair l v) r)+ Record (hUpdateAtHNat (Proxy::Proxy n) (newLVPair l v) r) infixr 2 .@. {-|@@ -476,7 +473,7 @@ > label1 .=. value1 .@. record1 -}-f@(LVPair v) .@. r = hUpdateAtLabel (labelLVPair f) v r+f@(Tagged v) .@. r = hUpdateAtLabel (labelLVPair f) v r -- --------------------------------------------------------------------------@@ -514,9 +511,9 @@ h2projectByLabels _ _ = (HNil,HNil) instance (HMemberM l1 ((l::k) ': ls) (b :: Maybe [k]),- H2ProjectByLabels' b (l ': ls) (LVPair l1 v1 ': r1) rin rout)- => H2ProjectByLabels (l ': ls) (LVPair l1 v1 ': r1) rin rout where- h2projectByLabels = h2projectByLabels' (undefined::(Proxy b))+ H2ProjectByLabels' b (l ': ls) (Tagged l1 v1 ': r1) rin rout)+ => H2ProjectByLabels (l ': ls) (Tagged l1 v1 ': r1) rin rout where+ h2projectByLabels = h2projectByLabels' (Proxy::Proxy b) class H2ProjectByLabels' (b::Maybe [k]) (ls::[k]) r rin rout | b ls r -> rin rout where@@ -526,7 +523,7 @@ instance H2ProjectByLabels ls1 r rin rout => H2ProjectByLabels' ('Just ls1) ls (f ': r) (f ': rin) rout where h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout)- where (rin,rout) = h2projectByLabels (undefined::Proxy ls1) r+ where (rin,rout) = h2projectByLabels (Proxy::Proxy ls1) r instance H2ProjectByLabels ls r rin rout => H2ProjectByLabels' 'Nothing ls (f ': r) rin (f ': rout) where@@ -572,7 +569,7 @@ The same as '.@.', except type preserving. It has the same fixity as (.\@.). -}-f@(LVPair v) .<. r = hTPupdateAtLabel (labelLVPair f) v r+f@(Tagged v) .<. r = hTPupdateAtLabel (labelLVPair f) v r -- -------------------------------------------------------------------------- -- | Subtyping for records@@ -593,14 +590,14 @@ instance ( RecordLabels r ~ ls , HMember l ls b- , HLeftUnionBool b r (LVPair l v) r'''+ , HLeftUnionBool b r (Tagged l v) r''' , HLeftUnion r''' r' r'' )- => HLeftUnion r (LVPair l v ': r') r''+ => HLeftUnion r (Tagged l v ': r') r'' where hLeftUnion r (Record (HCons f r')) = r'' where- r''' = hLeftUnionBool (proxy :: Proxy b) r f+ r''' = hLeftUnionBool (Proxy :: Proxy b) r f r'' = hLeftUnion (r''' :: Record r''') (Record r' :: Record r') class HLeftUnionBool (b :: Bool) r f r' | b r f -> r'@@ -659,12 +656,12 @@ instance ( RecordLabels r1 ~ ls , HMember l ls b- , UnionSymRec' b r1 (LVPair l v) r2' ru+ , UnionSymRec' b r1 (Tagged l v) r2' ru )- => UnionSymRec r1 (LVPair l v ': r2') ru+ => UnionSymRec r1 (Tagged l v ': r2') ru where unionSR r1 (Record (HCons f r2')) =- unionSR' (undefined::Proxy b) r1 f (Record r2')+ unionSR' (Proxy::Proxy b) r1 f (Record r2') class UnionSymRec' (b :: Bool) r1 f2 r2' ru | b r1 f2 r2' -> ru where unionSR' :: Proxy b -> Record r1 -> f2 -> Record r2' -> (Record ru, Record ru)@@ -680,15 +677,15 @@ -} instance (UnionSymRec r1 r2' ru, HasField l2 (Record ru) v2,- HUpdateAtHNat n (LVPair l2 v2) ru,- ru ~ HUpdateAtHNatR n (LVPair l2 v2) ru,+ HUpdateAtHNat n (Tagged l2 v2) ru,+ ru ~ HUpdateAtHNatR n (Tagged l2 v2) ru, RecordLabels ru ~ ls,- f2 ~ LVPair l2 v2,+ f2 ~ Tagged l2 v2, HFind l2 ls n) => UnionSymRec' True r1 f2 r2' ru where- unionSR' _ r1 (LVPair v2) r2' =+ unionSR' _ r1 (Tagged v2) r2' = case unionSR r1 r2'- of (ul,ur) -> (ul, hTPupdateAtLabel (undefined:: Label l2) v2 ur)+ of (ul,ur) -> (ul, hTPupdateAtLabel (Label :: Label l2) v2 ur) instance (UnionSymRec r1 r2' ru,@@ -718,8 +715,8 @@ HRearrange' l ls rin rout (HList r'), r'' ~ HList r') => HRearrange (l ': ls) r r'' where- hRearrange2 _ r = hRearrange2' (proxy :: Proxy l) (proxy :: Proxy ls) rin rout- where (rin, rout) = h2projectByLabels (proxy :: Proxy '[l]) r+ hRearrange2 _ r = hRearrange2' (Proxy :: Proxy l) (Proxy :: Proxy ls) rin rout+ where (rin, rout) = h2projectByLabels (Proxy :: Proxy '[l]) r -- | Helper class 2 for 'hRearrange'@@ -727,10 +724,10 @@ hRearrange2' :: Proxy l -> Proxy ls -> HList rin -> HList rout -> r' instance (HRearrange ls rout (HList r'),- r'' ~ HList (LVPair l v ': r')) =>- HRearrange' l ls '[LVPair l v] rout r'' where- hRearrange2' _ ls (HCons lv@(LVPair v) _HNil) rout- = HCons (LVPair v `asTypeOf` lv) (hRearrange2 ls rout)+ r'' ~ HList (Tagged l v ': r')) =>+ HRearrange' l ls '[Tagged l v] rout r'' where+ hRearrange2' _ ls (HCons lv@(Tagged v) _HNil) rout+ = HCons (Tagged v `asTypeOf` lv) (hRearrange2 ls rout) data ExtraField l = ExtraField data FieldNotFound l = FieldNotFound@@ -742,7 +739,7 @@ -- | For improved error messages instance Fail (ExtraField l) => - HRearrange '[] (LVPair l v ': a) (ExtraField l) where+ HRearrange '[] (Tagged l v ': a) (ExtraField l) where hRearrange2 _ _ = ExtraField
Data/HList/RecordPuns.hs view
@@ -12,7 +12,7 @@ import Data.HList.Record import Data.HList.FakePrelude import Data.List-+import Data.HList.HList {- $ex @@ -58,6 +58,18 @@ fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ which are in scope. +@( )@ parens mean the same thing as @{ }@, except the pattern match+restricts the fields in the record supplied to be exactly the ones+provided. In other words++> [pun| (x y) |] = list+> -- desugars to something like:+> Record (HCons (Tagged x :: Tagged "x" s1)+> (HCons (Tagged x :: Tagged "y" s2)+> HNil)) = list++Where the @s1@ and @s2@ are allowed to fit whatever is in the HList.+ See also @examples/pun.hs@. -} @@ -92,6 +104,7 @@ me :: Tree -> ExpQ me (C as) = foldr (\(l,e) acc -> [| $(mkPair l e) .*. $acc |]) [| emptyRecord |] (mes as)+me (D _as) = error "Data.HList.RecordPuns.mp impossible" me a = do reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a me (C [a])@@ -99,6 +112,7 @@ mes :: [Tree] -> [(String, ExpQ)] mes (V a : V "@": b : c) = (a, [| $(me b) `hLeftUnion` $(dyn a) |]) : mes c mes (V a : C b : c) = (a, me (C b)) : mes c+mes (V a : D b : c) = (a, me (C b)) : mes c mes (V a : b) = (a, varE (mkName a)) : mes b mes [] = [] mes inp = error $ "Data.HList.RecordPuns.mes: cannot translate remaining:" ++@@ -107,6 +121,19 @@ mp :: Tree -> PatQ mp (C as) = case unzip (mps as) of (a, b) -> viewP (extracts a) (tupP b)++-- use of prime here (non GADT version) because it is better for type+-- inference. See commentary surrounding HCons' in Data.HList.HList+mp (D as) = conP 'Record+ [viewP (varE 'prime) -- nicer to have [p| prime -> $( ... ) |],+ -- but ghc-7.6 rejects that over types+ (foldr ( \ (n,p) xs -> conP 'HCons'+ [viewP [| \x -> x `asTypeOf`+ (undefined :: Tagged $(litT (strTyLit n)) t) |]+ (conP 'Tagged [p]),+ xs])+ (conP 'HNil' [])+ (mps as))] mp a = do reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a mp (C [a])@@ -114,13 +141,16 @@ mps :: [Tree] -> [(String, PatQ)] mps (V a : V "@" : b : c) = (a, asP (mkName a) (mp b)) : mps c mps (V a : C b : c) = (a, mp (C b)) : mps c+mps (V a : D b : c) = (a, mp (D b)) : mps c mps (V a : b) = (a, varP (mkName a)) : mps b mps [] = [] mps inp = error $ "Data.HList.RecordPuns.mps: cannot translate remaining pattern:" ++ show (map ppTree inp) --data Tree = C [Tree] | V String deriving Show+data Tree = C [Tree] -- ^ curly @{ }@+ | D [Tree] -- ^ @( )@+ | V String -- ^ variable+ deriving Show {- | @@ -130,26 +160,32 @@ >>> ppTree $ parseRec "{a b c {d e {} f @ g}}" "{a b c {d e {} f @ g}}" -> ppTree $ parseRec "a b c {d e {} f @ g}"+>>> ppTree $ parseRec "a b c {d e {} f @ g}" "{a b c {d e {} f @ g}}" +>>> ppTree $ parseRec "(a b { (d) e } )"+"(a b {(d) e})"+ -} parseRec :: String -> Tree-parseRec str = case parseRec' 0 [[]] $ lexing str of+parseRec str = case parseRec' 0 0 [[]] $ lexing str of [x] -> x -- avoid adding another layer if possible x -> C (reverse x) -parseRec' :: Int -> [[Tree]] -> [String] -> [Tree]-parseRec' n accum ("{" : rest) = parseRec' (n+1) ([] : accum) rest-parseRec' n (a:b:c) ("}" : rest) = parseRec' (n-1) ((C (reverse a) : b) : c) rest-parseRec' n (b:c) (a : rest)- | a `notElem` ["{","}"] = parseRec' n ((V a : b) : c) rest-parseRec' 0 (a:_) [] = a-parseRec' _ accum e = error ("Data.HList.RecordPuns.parseRec' unexpected: " ++ show e+parseRec' :: Int -> Int -> [[Tree]] -> [String] -> [Tree]+parseRec' n m accum ("{" : rest) = parseRec' (n+1) m ([] : accum) rest+parseRec' n m accum ("(" : rest) = parseRec' n (m+1) ([] : accum) rest+parseRec' n m (a:b:c) ("}" : rest) = parseRec' (n-1) m ((C (reverse a) : b) : c) rest+parseRec' n m (a:b:c) (")" : rest) = parseRec' n (m-1) ((D (reverse a) : b) : c) rest+parseRec' n m (b:c) (a : rest)+ | a `notElem` ["{","}","(",")"] = parseRec' n m ((V a : b) : c) rest+parseRec' 0 0 (a:_) [] = a+parseRec' _ _ accum e = error ("Data.HList.RecordPuns.parseRec' unexpected: " ++ show e ++ "\n parsed:" ++ show (reverse accum)) ppTree :: Tree -> String ppTree (C ts) = "{" ++ unwords (map ppTree ts) ++ "}"+ppTree (D ts) = "(" ++ unwords (map ppTree ts) ++ ")" ppTree (V x) = x lexing = unfoldr (\v -> case lex v of
Data/HList/TIP.hs view
@@ -68,9 +68,9 @@ instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendList l l')) => HAppend (TIP l) (TIP l') where- type HAppendR (TIP l) (TIP l') = TIP (HAppendList l l') hAppend (TIP l) (TIP l') = mkTIP (hAppend l l') +type instance HAppendR (TIP l) (TIP l') = TIP (HAppendList l l') -- instance HOccurrence e l l' => HOccurrence e (TIP l) l' -- where@@ -145,7 +145,7 @@ ->>> Sheep .*. tipyDelete (proxy::Proxy Breed) myTipyCow+>>> Sheep .*. tipyDelete (Proxy::Proxy Breed) myTipyCow TIPH[Sheep, Key 42, Name "Angus", Price 75.5] >>> tipyUpdate Sheep myTipyCow
Data/HList/Variant.hs view
@@ -39,8 +39,8 @@ -- | Turn proxy sequence into sequence of Nothings data HMaybeF = HMaybeF-instance ((LVPair l (Proxy t) ~ a, b ~ LVPair l (Maybe t))) => ApplyAB HMaybeF a b where- applyAB _ _ = LVPair Nothing+instance ((Tagged l (Proxy t) ~ a, b ~ Tagged l (Maybe t))) => ApplyAB HMaybeF a b where+ applyAB _ _ = Tagged Nothing hMaybied x = hMap HMaybeF x
HList.cabal view
@@ -1,5 +1,5 @@ Name: HList-Version: 0.3.2.0+Version: 0.3.4.0 Category: Data Synopsis: Heterogeneous lists Description: HList is a record system providing strongly typed heterogenous lists, records,@@ -37,13 +37,13 @@ library- Build-Depends: base >= 4 && < 5, template-haskell, ghc-prim, mtl+ Build-Depends: base >= 4 && < 5, template-haskell, ghc-prim, mtl,+ tagged Exposed-modules: Data.HList, Data.HList.CommonMain, Data.HList.Data, Data.HList.FakePrelude,- Data.HList.FakePrelude.Proxy, Data.HList.HArray, Data.HList.HList, Data.HList.HListPrelude,
examples/MainGhcGeneric1.hs view
@@ -303,9 +303,9 @@ testVariant = (testVar1,(testVar2,(testVar3))) where- animalVar = key .=. (proxy::Proxy Integer)- .*. name .=. (proxy::Proxy String)- .*. breed .=. (proxy::Proxy Breed)+ animalVar = key .=. (Proxy::Proxy Integer)+ .*. name .=. (Proxy::Proxy String)+ .*. breed .=. (Proxy::Proxy Breed) .*. emptyRecord testVar1 = mkVariant name "angus" animalVar testVar2 = unVariant key testVar1
examples/TIPTransform.hs view
@@ -60,7 +60,7 @@ instance (HMember op db b, TransTIP' b op (TIP db)) => TransTIP op (TIP db) where- ttip = ttip' (proxy ::Proxy b)+ ttip = ttip' (Proxy ::Proxy b) class TransTIP' (b :: Bool) op db where ttip' :: Proxy b -> op -> db -> db
examples/TIPTransformM.hs view
@@ -127,7 +127,7 @@ -- can be instantiated either to a monad type constructor, or (arg->). instance (Monad m, HMember op db b, TransTIPM' b m (m' op) (TIP db)) => TransTIPM m (m' op) (TIP db) where- ttipM = ttipM' (proxy :: Proxy b)+ ttipM = ttipM' (Proxy :: Proxy b) class Monad m => TransTIPM' (b :: Bool) m op db where ttipM' :: Proxy b -> op -> db -> m db