HList 0.4.2.0 → 0.5.4.0
raw patch · 72 files changed
Files
- ChangeLog +63/−0
- Data/HList/CommonMain.hs +40/−16
- Data/HList/Data.hs +19/−3
- Data/HList/Dredge.hs +399/−0
- Data/HList/FakePrelude.hs +56/−11
- Data/HList/HArray.hs +13/−8
- Data/HList/HList.hs +61/−19
- Data/HList/HListPrelude.hs +41/−0
- Data/HList/HOccurs.hs +20/−14
- Data/HList/HSort.hs +17/−6
- Data/HList/HZip.hs +1/−1
- Data/HList/Label5.hs +4/−1
- Data/HList/Labelable.hs +48/−18
- Data/HList/MakeLabels.hs +9/−1
- Data/HList/Record.hs +35/−24
- Data/HList/RecordPuns.hs +42/−37
- Data/HList/RecordU.hs +8/−7
- Data/HList/TIC.hs +6/−3
- Data/HList/TIP.hs +71/−20
- Data/HList/Variant.hs +20/−3
- Data/HList/broken/VariantOld.hs +0/−68
- HList.cabal +63/−19
- LensDefs.hs +18/−2
- README +28/−11
- Setup.lhs +3/−113
- examples/Cabal.hs +0/−50
- examples/Datatypes1.hs +0/−14
- examples/Datatypes2.hs +0/−19
- examples/FooBar.hs +0/−27
- examples/HListExample.hs +49/−0
- examples/HListExample/CmdArgs.hs +146/−0
- examples/HListExample/Datatypes2.hs +19/−0
- examples/HListExample/Labelable.hs +64/−0
- examples/HListExample/MainGhcGeneric1.hs +288/−0
- examples/HListExample/MainPosting051106.hs +207/−0
- examples/HListExample/OverloadedLabels.hs +49/−0
- examples/HListExample/Prism.hs +126/−0
- examples/HListExample/Pun.hs +51/−0
- examples/HListExample/TIPTransform.hs +70/−0
- examples/HListExample/TIPTransformM.hs +144/−0
- examples/MainGhcGeneric1.hs +0/−318
- examples/MainGhcGeneric1.ref +0/−59
- examples/MainGhcGeneric2.hs +0/−22
- examples/MainGhcGeneric2.ref +0/−1
- examples/MainPatternMatch.hs +0/−80
- examples/MainPatternMatch.ref +0/−4
- examples/MainPosting-040607.hs +0/−304
- examples/MainPosting-040607.ref +0/−1
- examples/MainPosting-051106.hs +0/−197
- examples/MainPosting-051106.ref +0/−2
- examples/Properties.hs +4/−8
- examples/Properties/Common.hs +30/−0
- examples/Properties/KW.hs +58/−1
- examples/Properties/LengthDependent.hs +37/−8
- examples/Properties/LengthDependentSplice.hs +10/−4
- examples/Properties/LengthIndependent.hs +49/−7
- examples/TIPTransform.hs +0/−67
- examples/TIPTransform.ref +0/−6
- examples/TIPTransformM.hs +0/−130
- examples/TIPTransformM.ref +0/−8
- examples/broken/nn.hs +0/−37
- examples/cmdargs.hs +0/−96
- examples/cmdargs.ref +0/−9
- examples/labelable.hs +0/−47
- examples/labelable.ref +0/−11
- examples/lens.hs +0/−62
- examples/lens.ref +0/−19
- examples/prism.hs +0/−120
- examples/prism.ref +0/−37
- examples/pun.hs +0/−48
- examples/pun.ref +0/−9
- examples/runexamples.hs +0/−59
ChangeLog view
@@ -1,3 +1,66 @@+20 Feb 2025+0.5.4 Release+Merge Daniil's Itskov's changes:+ Add files for building with nix+ Build with ghc-9.10.1+Remove tests for hCurry and hCompose where ghc-9.4.8 has poor type inference+not seen in newer versions.++23 Sep 2023+0.5.3 Release+Build with ghc-9.4.6 and ghc-9.6.1.+ghc-9.4.6 cannot compile examples/Properties/LengthIndependent.hs+as some types cannot be inferred. This is fixed in ghc-9.6.1.++18 Feb 2022+0.5.2 Release+Remove custom Setup.lhs which was for ghc-7.6++Change to pun quasiquote improves error messages:+ For `f [pun| x y |] = ()`+ f :: _ => r (a ': b ': c) -> () -- old+ f :: _ => r as -> () -- new+Previously if you supplied a 9 element record to a function+needing 10 elements, the error would not name the missing field.+It is possible but unlikely that the old code will need to a type+annotation like+(id :: HLengthGE x (HSucc (HSucc HZero)) => r x -> r x)++23 Oct 2021+0.5.1 Release+Build & pass tests with ghc-8.4.4 through 9.2.0.20210821,+though with 9.2.0.20210821 dependencies for tests need+cabal flags --allow-newer=base --allow-newer=template-haskell,+and also invariant-functors and lens from git (as specified in `cabal.project`)++Add examples/HListExample/OverloadedLabels.hs++19 Feb 2018+0.5.0 Release+Build & pass tests with ghc-7.6 through 8.4.0.20180209++Add Dredge.hs (ghc>=7.8): access nested records/variants given only the last+label along a path++Move toLabel to another class to allow it to return Labels with+kinds other than Symbol.++tipyLens can now change the element type++Add hTake and hDrop++Use TypeError for prettier error messages in ghc-8.0 (still backwards+compatible)++Improve HFind and HUpdateAtHNat error messages by mentioning the whole+record being changed++22 Dec 2015+0.4.2 Release++Depend on base-orphans to avoid multiple definitions of Typeable '[],+Typeable '(:)+ 3 Aug 2015 0.4.1 Release
Data/HList/CommonMain.hs view
@@ -128,7 +128,8 @@ -- * Conversions between collections -- $convention the foo' optic has the same type as- -- @Control.Lens.simple . foo@. 'hLens'' is an exception to this rule.+ -- @Control.Lens.simple . foo . Control.Lens.simple@.+ -- 'hLens'' is an exception to this rule. , TypeIndexed(..) , typeIndexed'@@ -162,25 +163,39 @@ , Kw(..), recToKW, IsKeyFN, K, ErrReqdArgNotFound, ErrUnexpectedKW -- * Labels- {- | there are three options for now. However, there are- a couple different styles for the first option here:-- GHC supports type-level strings ('GHC.TypeLits.Symbol'), and these can be- labels. You can refer to these strings using an unwieldy syntax described- below. For example if you want to store a value @5@ in a record @rec@- with a field called @\"x\"@, and then get it out again:+ {- | By labels, we mean either the first argument to 'Tagged' (in the+ type-level lists that are supplied to 'Record', 'RecordU', 'TIP', 'TIC'),+ or the expressions used to specify those types to be able to look up+ the correct value in those collections. - let rec = ('Label' :: Label \"x\") '.=.' 5 '.*.' 'emptyRecord'+ Nearly all types can be labels. For example: - rec '.!.' (Label :: Label \"x\")+ @+ r :: Record '[Tagged "x" Int, -- kind GHC.TypeLits.Symbol + Tagged () (), -- see "Data.HList.Label5"+ Tagged (Lbl HZero LabelUniverse LabelMember1) () -- Label3+ ]+ r = 'hBuild' 8 () () -- don't need to use '.=.' / '.==.' and '.*.'+ -- if we have a type signature above+ @+ + we could define these variables - To avoid that pain, you can have a definition @x = Label :: Label "x"@.- and just use @x@ instead of repeating @Label :: Label \"x\"@ so that- a lookup becomes:+ @+ xLabel = Label :: Label \"x\" -- 'makeLabels6' ["x"] would define x with the same RHS+ xLens = hLens' xLabel -- 'makeLabelable' "x" would define x with the same RHS+ @ - > rec .!. x+ to access the @8@ given above: - 'makeLabels6' automates definitions like @x = Label :: Label \"x\"@.+ @+ r '.!.' xLabel+ r ^. xLens -- alternatively Control.Lens.view+ r ^. `x -- with HListPP is used (not in ghci),+ -- which avoids the issue of conflicting+ -- definitions of x, which mean the same+ -- thing+ @ -} -- $label6demo@@ -188,6 +203,14 @@ , module Data.HList.Labelable -- $labelable + -- ** "Data.HList.Dredge"+ -- *** lenses+ , dredge, dredge'+ , dredgeND, dredgeND'+ , dredgeTI'+ -- *** plain lookup+ , hLookupByLabelDredge, HasFieldPath+ -- ** namespaced labels , module Data.HList.Label3 @@ -216,7 +239,6 @@ import Data.HList.HOccurs import Data.HList.HTypeIndexed import Data.HList.Record--- import Data.HList.RecordU -- import Data.HList.RecordOrd import Data.HList.HList hiding (append', hAppend',@@ -250,6 +272,8 @@ import Data.HList.Keyword import Data.HList.RecordPuns import Data.HList.RecordU++import Data.HList.Dredge {- $label6demo #label6demo#
Data/HList/Data.hs view
@@ -100,7 +100,9 @@ -- | this data type only exists to have Data instance newtype HListFlat a = HListFlat (HList a) -type DataHListFlatCxt na g a = (HBuild' '[] g,+type DataHListFlatCxt na g a = (+ g ~ FoldRArrow a (HList a),+ HBuild' '[] g, Typeable (HListFlat a), TypeablePolyK a, HFoldl (GfoldlK C) (C g) a (C (HList a)),@@ -112,8 +114,22 @@ (C (HList a)), HLengthEq a na,- HReplicate na ()- )+ HReplicate na ())+++-- | ghc-8.0.2 can't work out the type g,+-- in the 2nd argument of gfoldl. ghc <= 7.10+-- don't need it.+--+-- in `instance Data (HListFlat '[a,b,c])`+--+-- > g ~ (a -> b -> c -> HList '[a,b,c])+-- > g ~ GetG '[a,b,c] (HList '[a,b,c])+type family FoldRArrow (xs :: [*]) (r :: *)++type instance FoldRArrow '[] r = r+type instance FoldRArrow (x ': xs) r = x -> FoldRArrow xs r + instance DataHListFlatCxt na g a => Data (HListFlat a) where gfoldl k z (HListFlat xs) = c3 $
+ Data/HList/Dredge.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+-- TryCollectionList needs overlap+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+{- | Description: access nested records/variants given only the last label along a path -}+module Data.HList.Dredge where++import Data.HList.Record+import Data.HList.Variant+import Data.HList.HList+import Data.HList.TIP+import Data.HList.TIC+import Data.HList.FakePrelude+import Data.HList.Labelable+import LensDefs (isSimple)+import Data.HList.TypeEqO () -- if this is missing, dredge fails+++#if (__GLASGOW_HASKELL__ == 800)+-- https://ghc.haskell.org/trac/ghc/ticket/13371+toLabelx x = toLabelSym x+#else+toLabelx x = toLabel x+#endif++{- |++Using HListPP syntax for short hand, @dredge `foo@ expands out to+something like @`path . `to . `foo@, with the restriction that+there is only one possible @`path . `to@ which leads to the+label @foo@.++For example, if we have the following definitions,++> type BVal a = Record '[Tagged "x" a, Tagged "a" Char]+> type R a = Record [Tagged "a" Int, Tagged "b" (BVal a)]+> type V a = Variant [Tagged "a" Int, Tagged "b" (BVal a)]+> lx = Label :: Label "x"++Then we have:++> dredge `x :: Lens (R a) (R b) a b+> dredge lx :: Lens (R a) (R b) a b++> dredge `x :: Traversal (V a) (V b) a b -- there were only variants along the path we'd get a Prism+> dredge lx :: Traversal (V a) (V b) a b++[@result-type directed operations are supported@]++There are two ways to access a field with tag @a@ in the R type+defined above, but they result in fields with different types+being looked up:++> `a :: Lens' (R a) Char+> `b . `a :: Lens' (R a) Int++so provided that the result type is disambiguated by the context,+the following two types can happen++> dredge `a :: Lens' (R a) Char+> dredge `a :: Lens' (R a) Int+++[@TIP & TIC@]++type indexed collections are allowed along those paths, but+as explained in the 'Labelable' instances, only simple optics+(Lens' / Prism' / Traversal' ) are produced. @dredgeTI'@+works better if the target is a TIP or TIC++-}+dredge label = getSAfromOutputOptic $ \ pr pa ->+ hLens'Path (labelPathEndingWithTD pr (toLabelx label) pa)++++getSAfromOutputOptic :: (p a fb -> p rs rft) ~ stab+ => (Proxy (rs :: *) -> Proxy (a :: *) -> stab) -> stab+getSAfromOutputOptic f = f Proxy Proxy+++-- | 'dredge' except a simple (s ~ t, a ~ b) optic is produced+dredge' label = isSimple (dredge label)+++-- | dredgeND (named directed only) is the same as 'dredge', except the+-- result type (@a@) is not used when the label would otherwise+-- be ambiguous. dredgeND might give better type errors, but otherwise+-- there should be no reason to pick it over dredge+dredgeND label = getSAfromOutputOptic $ \ pr _a ->+ hLens'Path (labelPathEndingWith pr (toLabelx label))+++-- | 'dredgeND' except a simple (s ~ t, a ~ b) optic is produced+dredgeND' label = isSimple (dredgeND label)+++{- | The same as dredgeND', except intended for TIP/TICs because+the assumption is made that @l ~ v@ for the @Tagged l v@ elements.+In other words, ticPrism' and 'tipyLens'' could usually+be replaced by++> dredgeTI' :: _ => Label a -> Lens' (TIP s) a+> dredgeTI' :: _ => Label a -> Prism' (TIC s) a++where we might have @s ~ '[Tagged a a, Tagged b b]@++-}+dredgeTI' label = isSimple lens where+ lens = getSAfromOutputOptic $ \ pr pa ->+ hLens'Path (labelPathEndingWith pr (pa `proxyTypeOf` label))++ proxyTypeOf :: p a -> q a -> Label a+ proxyTypeOf _ _ = Label+++-- | @HSingleton msg xs x@ is like @'[x] ~ xs@ if that constraint can hold,+-- otherwise it is @Fail msg@. See comments on 'Fail' about how its kind+-- varies with ghc version.+class HSingleton (msgAmb :: m) (msgEmpty :: m2) (ns :: [k]) (p :: k) | ns -> p+instance HSingleton m1 m2 '[n] n+instance (Fail m2, Any ~ a) => HSingleton m1 m2 '[] a+instance (Fail m1, Any ~ a) => HSingleton m1 m2 (n1 ': n2 ': n3) a+++-- | @HGuardNonNull msg xs@ is like @when (null xs) (fail msg)@+class HGuardNonNull emptymsg (xs :: [k])++instance Fail msg => HGuardNonNull msg '[]+instance HGuardNonNull msg (x ': xs)+++-- | @ConsTrue b x xs r@ is like @r = if b then x:xs else xs@+class ConsTrue (b :: Bool) (x :: k) (xs :: [k]) (r :: [k]) | b x xs -> r, r b -> xs, x xs r -> b+instance ConsTrue True x xs (x ': xs)+instance ConsTrue False x xs xs++-- | @FilterLastEq x xs ys ys'@ determines ys' such that it+-- contains all of the @ys !! i@ such that @last (xs !! i) == x@.+-- In other words it is like+--+-- > ys' = [ y | (xsElt, y) <- zip xs ys, last xsElt == x ]+class FilterLastEq (x :: k) (xs :: [[k]]) (ys :: [m]) (ys' :: [m]) | x xs ys -> ys'+instance (HReverse path (y' ': rest), HEq y y' b, ConsTrue b z r1 r,+ FilterLastEq y xs zs r1) => FilterLastEq y (path ': xs) (z ': zs) r++instance FilterLastEq y '[] '[] '[]++-- | The same as 'FilterLastEq' except @id@ is used instead of @last@+class FilterVEq (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'++instance FilterVEq v '[] '[] '[]++instance+ (HEq v v' b,+ ConsTrue b n ns1 ns2,+ FilterVEq v vs ns ns1)+ => FilterVEq v (v' ': vs) (n ': ns) ns2++-- | like @FilterVEq@, except if there is+class FilterVEq1 (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'+instance (v ~ v') => FilterVEq1 v '[ v' ] ns ns+instance FilterVEq1 v '[] '[] '[]+instance FilterVEq v (a ': b ': c) ns ns' => FilterVEq1 v (a ': b ': c) ns ns'++-- | @LabelPathEndingWith r l path@+--+-- determines a unique path suitable for 'hLookupByLabelPath'+-- (calling 'Fail' otherwise) through the+-- nested records/variants in r ending with l+class LabelPathEndingWith (r :: *) (l :: k) (path :: [*]) | r l -> path where+ labelPathEndingWith :: proxy r -> Label l -> Label path+ labelPathEndingWith _ _ = Label++instance+ (FieldTree r ns,+ FilterLastEq (Label l) ns ns ns',+ HSingleton (NonUnique' r l) (NamesDontMatch r ns l) ns' path)+ => LabelPathEndingWith r l path+++labelPathEndingWithTD :: forall r l v path+ vs vs1 ns ns1 ns2.+ (SameLength ns vs,+ SameLength ns1 vs1,+ FieldTree r ns,+ FieldTreeVal r vs,+ FilterLastEq (Label l) ns ns ns1,+ FilterLastEq (Label l) ns vs vs1,+ FilterVEq1 v vs1 ns1 ns2,++ HGuardNonNull (NamesDontMatch r ns l) ns1,++ -- '[path] ~ ns2, plus error reporting if ns2 has >1 or 0 elements+ HSingleton (NonUnique r v l) (TypesDontMatch r ns1 vs1 v) ns2 path)+ => Proxy r -> Label l -> Proxy v -> Label path+labelPathEndingWithTD _ _ _ = Label+++type NamesDontMatch r ns l = ErrShowType r+ :$$: ErrText "has paths" :<>: ErrShowType ns+ :$$: ErrText "but none which end in the desired label" :<>: ErrShowType l++type NonUnique' r l = ErrText "Path ending in label " :<>: ErrShowType l+ :$$: ErrText "is not unique in " :<>: ErrShowType r++type NonUnique r v l = NonUnique' r l+ :$$: ErrText "also considering the v type " :<>: ErrShowType v++{- | XXX++> let x = 'x'; y = [pun| x |]; z = [pun| y |]+> z & dredge (Label :: Label "x") %~ (succ :: Int -> Int)++Should reference this type error, but for whatever reason it doesn't++-}+type TypesDontMatch r ns1 vs1 v = ErrShowType r+ :$$: ErrText "has potential paths with the right labels" :<>: ErrShowType ns1+ :$$: ErrText "which point at types" :<>: ErrShowType vs1 :<>: ErrText "respectively"+ :$$: ErrText "but none of these match the desired type" :<>: ErrShowType v++-- | see 'hLookupByLabelPath'+hLookupByLabelDredge l r = labelPathEndingWith (toProxy r) l `hLookupByLabelPath` r+ where toProxy :: r x -> Proxy x+ toProxy _ = Proxy++{- | lookup along a path++>>> let v = mkVariant1 Label (mkVariant1 Label 'r') :: Variant '[Tagged "x" (Variant '[Tagged "y" Char])]+>>> let r = hBuild (hBuild 'r') :: Record '[Tagged "x" (Record '[Tagged "y" Char])]+>>> let p = Label :: Label [Label "x", Label "y"]+>>> let lx = Label :: Label "y"++>>> hLookupByLabelPath p v+Just 'r'++>>> hLookupByLabelPath p r+'r'++>>> hLookupByLabelDredge lx v+Just 'r'++>>> hLookupByLabelDredge lx r+'r'++-}+hLookupByLabelPath :: HasFieldPath False ls r v => Label ls -> r -> v+hLookupByLabelPath labels r = hLookupByLabelPath1 hFalse labels r++{- |++> hLens'Path labc == hLens' la . hLens' lb . hLens' lc+> where+> la :: Label "a"+> lb :: Label "b"+> lc :: Label "c"+> labc :: Label '["a", "b", "c"]++-}+class LabelablePath (xs :: [*]) apb spt | spt xs -> apb where+ hLens'Path :: Label xs -> apb -> spt++instance (Labelable x r s t a b,+ j ~ (a `p` f b),+ k ~ (r s `p` f (r t)),+ ty ~ LabelableTy r,+ LabeledOpticP ty p,+ LabeledOpticF ty f,+ LabeledOpticTo ty x (->),+ LabelablePath xs i j) => LabelablePath (Label x ': xs) i k where+ hLens'Path _ = (hLens' (Label :: Label x) :: j -> k) . hLens'Path (Label :: Label xs)++instance (x ~ x') => LabelablePath '[] x x' where+ hLens'Path _ = id++class HasFieldPath (needJust :: Bool) (ls :: [*]) r v | needJust ls r -> v where+ -- | use 'hLookupByLabelPath' instead+ hLookupByLabelPath1 :: Proxy needJust -> Label ls -> r -> v++instance HasFieldPath False '[] v v where+ hLookupByLabelPath1 _ _ = id++instance HasFieldPath True '[] v (Maybe v) where+ hLookupByLabelPath1 _ _ = Just++instance (HasField l (Record r) u, HasFieldPath needJust ls u v)+ => HasFieldPath needJust (Label l ': ls) (Record r) v where+ hLookupByLabelPath1 needJust _ = hLookupByLabelPath1 needJust (Label :: Label ls)+ . hLookupByLabel (Label :: Label l)++instance (HasField l (Variant r) (Maybe u), HasFieldPath True ls u (Maybe v))+ => HasFieldPath needJust (Label l ': ls) (Variant r) (Maybe v) where+ hLookupByLabelPath1 _ _ v = hLookupByLabelPath1 hTrue (Label :: Label ls) =<< hLookupByLabel (Label :: Label l) v++++++{- | @(FieldTree r ns, FieldTreeVal r vs)@++defines ns and vs such that looking up path (ns !! i) in r gives the type+(vs !! i). This is almost @HasFieldPath False (ns !! i) (vs !! i)@, except+there is no additional Maybe when a Variant is encountered along the path+(and we don't have a type level @!!@)+-}+class FieldTreeVal (r :: *) (v :: [*]) | r -> v++class MapFieldTreeVal (r :: *) (ns :: Maybe [*]) (vs :: [*]) | r ns -> vs++instance (TryCollectionList r ns, MapFieldTreeVal r ns v) => FieldTreeVal r v++instance MapFieldTreeVal r Nothing '[]++instance ( MapFieldTreeVal r (Just xs) out2,+ FieldTreeVal v out1,+ (v ': HAppendListR out1 out2) ~ out)+ => MapFieldTreeVal r (Just (Tagged n v ': xs)) out++instance MapFieldTreeVal r (Just '[]) '[]++{- | list all paths through nested records or variants.+An example instance would be++> FieldTree r v++where++> v ~ [[ Label "x", Label Dat ], '[Label "y"], '[Label "x"] ]+> r ~ Record [ Tagged "x" x, Tagged "y" String ]+>+> x ~ Variant '[ Tagged Dat Char ]++-}+class FieldTree (r :: *) (v :: [[*]]) | r -> v++-- | the only instance+instance (TryCollectionList r ns, MapFieldTree ns vs) => FieldTree r vs+++#if (__GLASGOW_HASKELL__ >= 800)+-- possibly https://ghc.haskell.org/trac/ghc/ticket/13284+-- dredge' x = (isSimple . dredge) x+-- • Overlapping instances for TryCollectionList r0 ns0+-- arising from a use of ‘dredge’+-- Matching instances:+-- instance [overlappable] nothing ~ 'Nothing =>+-- TryCollectionList x nothing+-- -- Defined at /home/aavogt/wip/HList/HList/Data/HList/Dredge.hs:340:31+-- ...plus four instances involving out-of-scope types+-- (use -fprint-potential-instances to see them all)+-- (The choice depends on the instantiation of ‘r0, ns0’+-- To pick the first instance above, use IncoherentInstances+-- when compiling the other instance declarations)+--+-- attempt to resolve that with a closed type family++type family TryCollectionListTF (r :: *) :: Maybe [*] where+ TryCollectionListTF (Record r) = Just r+ TryCollectionListTF (Variant r) = Just r+ TryCollectionListTF (TIC r) = Just r+ TryCollectionListTF (TIP r) = Just r+ TryCollectionListTF nothing = Nothing++type TryCollectionList r v = (v ~ TryCollectionListTF r)++#else+-- | try to extract the list applied to the Record or Variant+class TryCollectionList (r :: *) (v :: Maybe [*]) | r -> v++instance {-# OVERLAPPABLE #-} (nothing ~ Nothing) => TryCollectionList x nothing+instance {-# OVERLAPPING #-} TryCollectionList (Record r) (Just r)+instance {-# OVERLAPPING #-} TryCollectionList (Variant r) (Just r)+instance {-# OVERLAPPING #-} TryCollectionList (TIC r) (Just r)+instance {-# OVERLAPPING #-} TryCollectionList (TIP r) (Just r)+#endif++class MapFieldTree (ns :: Maybe [*]) (vs :: [[*]]) | ns -> vs++instance MapFieldTree Nothing '[]++-- | recursive case+instance (+ MapFieldTree (Just xs) vs3,+ FieldTree v vs1,+ MapCons (Label n) ('[] ': vs1) vs2,+ HAppendListR vs2 vs3 ~ vs)+ => MapFieldTree (Just (Tagged n v ': xs)) vs++instance MapFieldTree (Just '[]) '[]++-- | MapCons x xs xxs is like xxs = map (x : ) xs+class MapCons (x :: k) (xs :: [[k]]) (xxs :: [[k]]) | x xs -> xxs+instance MapCons x '[] '[]+instance MapCons x b r => MapCons x (a ': b) ( (x ': a) ': r)++
Data/HList/FakePrelude.hs view
@@ -10,15 +10,22 @@ module Data.HList.FakePrelude (module Data.HList.FakePrelude,+ -- * re-exports module Data.Proxy, module Data.Tagged,- Monoid(..)) where+ Monoid(..),+ Any) where import Data.Proxy import Data.Tagged-import GHC.Prim (Constraint)+import GHC.Exts (Constraint,Any) import GHC.TypeLits+#if __GLASGOW_HASKELL__ >= 800+import qualified GHC.TypeLits as Data.HList.FakePrelude (ErrorMessage((:$$:), (:<>:))) -- XXX check this works?+#endif+#if __GLASGOW_HASKELL__ <= 906 import Control.Applicative+#endif #if NEW_TYPE_EQ import Data.Type.Equality (type (==)) #endif@@ -28,7 +35,7 @@ #endif #if __GLASGOW_HASKELL__ < 709-import Data.Monoid+import Data.Monoid (Monoid(..)) #endif @@ -285,7 +292,7 @@ -} data HComp g f = HComp g f -- ^ @g . f@ -instance forall f g a b c. (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where+instance (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where applyAB ~(HComp g f) x = applyAB g (applyAB f x :: b) @@ -682,17 +689,54 @@ -- * Error messages --- | A class without instances for explicit failure-class Fail x+{- | A class without instances for explicit failure. +Note that with ghc>=8.0, `x :: TypeError` which is formatted properly.+Otherwise `x` is made of nested (left-associated) promoted tuples.+For example: --- ** Uses of fail--- $note these could be replaced by `'("helpful message", l)`,--- but these look better.-data ExtraField l-data FieldNotFound l+> (x ~ '( '( '("the", Int), "is wrong") ) ) :: ((,) Symbol *, Symbol) +Therefore code that works across ghc-7.6 through ghc-8.0 needs to+use ErrText, ErrShowType, :<>:, :$$: to construct the type x. -}+class Fail (x :: k) +#if __GLASGOW_HASKELL__ >= 800+-- | use the alias ErrText to prevent conflicts with Data.Text+--+-- GHC.TypeLits.:<>: and GHC.TypeLits.:$$: are re-exported+type ErrText x = GHC.TypeLits.Text x+type ErrShowType x = GHC.TypeLits.ShowType x++-- type Fail = TypeError -- another option+instance TypeError x => Fail x+#else++type ErrText x = x+type ErrShowType x = x+type x :<>: y = '(x,y)+type x :$$: y = '(x,y)+infixl 6 :<>:+infixl 5 :$$:+#endif++-- ** Error messages used elsewhere+type FieldNotFound key collection = ErrText "key" :<>: ErrShowType key+ :$$: ErrText "could not be found in" :<>: ErrShowType collection++type ExcessFieldFound key collection = ErrText "found field" :<>: ErrShowType key+ :$$: ErrText "when it should be absent from" :<>: ErrShowType collection++type HNatIndexTooLarge (nat :: HNat) (r :: [k] -> *) (xs :: [k]) =+ ErrText "0-based index" :<>: ErrShowType (HNat2Nat nat) :<>:+ ErrText "is too large for collection"+ :$$: ErrShowType (r xs)+ -- :$$: ErrText "(length: " :<>: ErrShowType (HNat2Nat (HLength collection)) :<>: ErrText " )"+ -- Data.HList.HList.HLength isn't available here++type ExtraField x = ErrText "extra field" :<>: ErrShowType x++ #if OLD_TYPEABLE type TypeablePolyK a = (() :: Constraint) #else@@ -730,6 +774,7 @@ sameLength :: r x `p` f (q y) -> r x `p` f (q y) sameLength = id +-- | 'asTypeOf' asLengthOf :: SameLength x y => r x -> s y -> r x asLengthOf = const
Data/HList/HArray.hs view
@@ -47,22 +47,27 @@ -- -------------------------------------------------------------------------- -- * Update+class HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where+ hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) -class HUpdateAtHNat (n :: HNat) e (l :: [*]) where+instance HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where+ hUpdateAtHNat = hUpdateAtHNat' (Proxy :: Proxy l)++class HUpdateAtHNat' (n :: HNat) e (l :: [*]) (l0 :: [*]) where type HUpdateAtHNatR (n :: HNat) e (l :: [*]) :: [*]- hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l)+ hUpdateAtHNat' :: Proxy l0 -> Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) -instance HUpdateAtHNat HZero e1 (e ': l) where+instance HUpdateAtHNat' HZero e1 (e ': l) l0 where type HUpdateAtHNatR HZero e1 (e ': l) = e1 ': l- hUpdateAtHNat _ e1 (HCons _ l) = HCons e1 l+ hUpdateAtHNat' _ _ e1 (HCons _ l) = HCons e1 l -instance HUpdateAtHNat n e1 l => HUpdateAtHNat (HSucc n) e1 (e ': l) where+instance HUpdateAtHNat' n e1 l l0 => HUpdateAtHNat' (HSucc n) e1 (e ': l) l0 where type HUpdateAtHNatR (HSucc n) e1 (e ': l) = e ': (HUpdateAtHNatR n e1 l)- hUpdateAtHNat n e1 (HCons e l) = HCons e (hUpdateAtHNat (hPred n) e1 l)+ hUpdateAtHNat' l0 n e1 (HCons e l) = HCons e (hUpdateAtHNat' l0 (hPred n) e1 l) -instance Fail (FieldNotFound (Proxy n, e1)) => HUpdateAtHNat n e1 '[] where+instance Fail (HNatIndexTooLarge n HList l0) => HUpdateAtHNat' n e1 '[] l0 where type HUpdateAtHNatR n e1 '[] = '[]- hUpdateAtHNat _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances"+ hUpdateAtHNat' _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances" -- -------------------------------------------------------------------------- -- * Projection
Data/HList/HList.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {- | The HList library @@ -5,9 +6,6 @@ Basic declarations for typeful heterogeneous lists. - Excuse the unstructured haddocks: while there are many declarations here- some are alternative implementations should be grouped, and the definitions- here are analgous to many list functions in the "Prelude". -} module Data.HList.HList where@@ -22,6 +20,10 @@ import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup+#endif+ -- -------------------------------------------------------------------------- -- * Heterogeneous type sequences {- $note@@ -173,10 +175,10 @@ show _ = "H[]" instance (Show e, Show (HList l)) => Show (HList (e ': l)) where- show (HCons x l) = let 'H':'[':s = show l- in "H[" ++ show x ++- (if s == "]" then s else "," ++ s)-+ show (HCons x l) =+ case show l of+ 'H':'[':s -> "H[" ++ show x ++ (if s == "]" then s else "," ++ s)+ s -> error $ "unreachable branch: " ++ show x ++ " " ++ s instance Read (HList '[]) where readsPrec _ str = case stripPrefix "H[]" str of@@ -490,7 +492,7 @@ class HFoldl f (z :: *) xs (r :: *) where hFoldl :: f -> z -> HList xs -> r -instance forall f z z' r x zx xs. (zx ~ (z,x), ApplyAB f zx z', HFoldl f z' xs r)+instance (zx ~ (z,x), ApplyAB f zx z', HFoldl f z' xs r) => HFoldl f z (x ': xs) r where hFoldl f z (x `HCons` xs) = hFoldl f (applyAB f (z,x) :: z') xs @@ -995,17 +997,17 @@ -- * Find an element in a set based on HEq -- | It is a pure type-level operation-class HFind1 e l n => HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n-instance HFind1 e l n => HFind e l n+class HFind1 e l l n => HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n+instance HFind1 e l l n => HFind e l n -class HFind1 (e :: k) (l :: [k]) (n :: HNat) | e l -> n+class HFind1 (e :: k) (l :: [k]) (l0 :: [k]) (n :: HNat) | e l -> n -instance (HEq e1 e2 b, HFind2 b e1 l n) => HFind1 e1 (e2 ': l) n-instance Fail (FieldNotFound e1) => HFind1 e1 '[] HZero+instance (HEq e1 e2 b, HFind2 b e1 l l0 n) => HFind1 e1 (e2 ': l) l0 n+instance Fail (FieldNotFound e1 l0) => HFind1 e1 '[] l0 HZero -class HFind2 (b::Bool) (e :: k) (l::[k]) (n:: HNat) | b e l -> n-instance HFind2 True e l HZero-instance HFind1 e l n => HFind2 False e l (HSucc n)+class HFind2 (b::Bool) (e :: k) (l::[k]) (l0::[k]) (n:: HNat) | b e l -> n+instance HFind2 True e l l0 HZero+instance HFind1 e l l0 n => HFind2 False e l l0 (HSucc n) @@ -1097,7 +1099,7 @@ -- | @Prism' [a] (HList s)@ -- -- where @s ~ HReplicateR n a@-listAsHList' x = simple (listAsHList (simple x))+listAsHList' x = isSimple listAsHList x -- --------------------------------------------------------------------------@@ -1354,6 +1356,14 @@ instance (HLengthEq xs n, sn ~ HSucc n) => HLengthEq2 (x ': xs) sn instance zero ~ HZero => HLengthEq2 '[] zero +-- | @HLengthGe xs n@ says that @HLength xs >= n@.+--+-- unlike the expression with a type family HLength,+-- ghc assumes @xs ~ (aFresh ': bFresh)@ when given a+-- constraint @HLengthGe xs (HSucc HZero)@+class HLengthGe (xs :: [*]) (n :: HNat)+instance (HLengthGe xs n, xxs ~ (x ': xs)) => HLengthGe xxs (HSucc n)+instance HLengthGe xxs HZero -- | @HAppendList1 xs ys xsys@ is the type-level way of saying @xs ++ ys == xsys@ --@@ -1375,6 +1385,30 @@ instance HStripPrefix '[] ys ys +-- ** take++class HTake (n :: HNat) xs ys | n xs -> ys where+ hTake :: (HLengthEq ys n, HLengthGe xs n) => Proxy n -> HList xs -> HList ys++instance HTake HZero xs '[] where+ hTake _ _ = HNil++instance (HLengthEq ys n, HLengthGe xs n, HTake n xs ys)+ => HTake (HSucc n) (x ': xs) (x ': ys) where+ hTake sn (HCons x xs) = HCons x (hTake (hPred sn) xs)++-- ** drop++class HDrop (n :: HNat) xs ys | n xs -> ys where+ hDrop :: HLengthGe xs n => Proxy n -> HList xs -> HList ys++instance HDrop HZero xs xs where+ hDrop _ xs = xs++instance (HLengthGe xs n, HDrop n xs ys) => HDrop (HSucc n) (x ': xs) ys where+ hDrop sn (HCons _ xs) = hDrop (hPred sn) xs++ -- * Conversion to and from tuples class HTuple v t | v -> t, t -> v where@@ -1386,7 +1420,7 @@ hTuple x = iso hToTuple hFromTuple x -- | @Iso' (HList v) a@-hTuple' x = simple (hTuple x)+hTuple' x = isSimple hTuple x instance HTuple '[] () where hToTuple HNil = ()@@ -1599,8 +1633,14 @@ HMapCxt HList UncurryMappend aa a) => Monoid (HList a) where mempty = hMap ConstMempty $ (hProxies :: HList (AddProxy a))+#if __GLASGOW_HASKELL__ <= 906 mappend a b = hMap UncurryMappend $ hZip a b+#endif +instance+ (HZip HList a a aa,+ HMapCxt HList UncurryMappend aa a) => Semigroup (HList a) where+ a <> b = hMap UncurryMappend $ hZip a b -- ** helper functions @@ -1612,4 +1652,6 @@ instance (aa ~ (a,a), Monoid a) => ApplyAB UncurryMappend aa a where applyAB _ = uncurry mappend -+data UncurrySappend = UncurrySappend+instance (aa ~ (a,a), Semigroup a) => ApplyAB UncurrySappend aa a where+ applyAB _ = uncurry (<>)
Data/HList/HListPrelude.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {- | The HList library@@ -92,5 +93,45 @@ -- | 'zip'. Variant supports hUnzip, but not hZip ('hZipVariant' returns a Maybe) class HUnzip r x y xy => HZip (r :: [*] -> *) x y xy where hZip :: r x -> r y -> r xy++#if __GLASGOW_HASKELL__ != 706+instance (lv ~ Tagged l v, HUnzip Proxy ls vs lvs)+ => HUnzip Proxy (Label l ': ls) (v ': vs) (lv ': lvs) where+ hUnzip _ = (Proxy, Proxy)++instance HUnzip Proxy '[] '[] '[] where hUnzip _ = (Proxy, Proxy)+++{- | Missing from GHC-7.6.3 due to a bug:++> let r = hEnd $ hBuild 1 2 3+> *Data.HList> hZipList r r+> H[(1,1),(2,2),(3,3)]+> *Data.HList> hZip r r+>+> <interactive>:30:1:+> Couldn't match type `Label k l' with `Integer'+> When using functional dependencies to combine+> HUnzip+> (Proxy [*]) ((':) * (Label k l) ls) ((':) * v vs) ((':) * lv lvs),+> arising from the dependency `xy -> x y'+> in the instance declaration at Data/HList/HListPrelude.hs:96:10+> HUnzip+> HList+> ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+> ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+> ((':)+> *+> (Integer, Integer)+> ((':) * (Integer, Integer) ((':) * (Integer, Integer) ('[] *)))),+> arising from a use of `hZip' at <interactive>:30:1-4+> In the expression: hZip r r+> In an equation for `it': it = hZip r r++-}+instance HUnzip Proxy ls vs lvs+ => HZip Proxy ls vs lvs where+ hZip _ _ = Proxy+#endif
Data/HList/HOccurs.hs view
@@ -82,18 +82,21 @@ data TypeNotFound e -instance (HOccurrence e (x ': y) l', HOccurs' e l')+instance (HOccurrence e (x ': y) l', HOccurs' e l' (x ': y)) => HOccurs e (HList (x ': y)) where- hOccurs = hOccurs' . hOccurrence (Proxy ::Proxy e)+ hOccurs = hOccurs' (Proxy :: Proxy (x ': y)) . hOccurrence (Proxy ::Proxy e) -class HOccurs' e l where- hOccurs' :: HList l -> e+-- | l0 is the original list so that when we reach the end of l+-- without finding an e, we can report an error that gives an+-- idea about what the original list was.+class HOccurs' e l (l0 :: [*]) where+ hOccurs' :: Proxy l0 -> HList l -> e -instance Fail (TypeNotFound e) => HOccurs' e '[] where- hOccurs' = error "Data.HList.FakePrelude.Fail must have no instances"+instance Fail (FieldNotFound e (HList l0)) => HOccurs' e '[] l0 where+ hOccurs' = error "HOccurs'' Fail failed" -instance (e ~ e1, HOccursNot e l) => HOccurs' e (e ': l) where- hOccurs' (HCons e _) = e+instance HOccursNot e l => HOccurs' e (e ': l) l0 where+ hOccurs' _ (HCons e _) = e -- | lookup a value in the collection (TIP usually) and return the TIP with that -- element deleted. Used to implement 'tipyTuple'.@@ -122,12 +125,15 @@ -- -------------------------------------------------------------------------- -- Class to test that a type is "free" in a type sequence -data TypeFound e-instance HOccursNot e ('[]::[*])-instance (HEq e e1 b, HOccursNot' b e l) => HOccursNot e (e1 ': l)-class HOccursNot' (b :: Bool) e (l :: [*])-instance Fail (TypeFound e) => HOccursNot' True e l-instance HOccursNot e l => HOccursNot' False e l+instance HOccursNot1 e xs xs => HOccursNot e xs++class HOccursNot1 (e :: k) (xs :: [k]) (xs0 :: [k])++instance HOccursNot1 (e :: k) ('[]::[k]) l0+instance (HEq e e1 b, HOccursNot2 b e l l0) => HOccursNot1 e (e1 ': l) l0+class HOccursNot2 (b :: Bool) e (l :: [k]) (l0 :: [k])+instance Fail (ExcessFieldFound e l0) => HOccursNot2 True e l l0+instance HOccursNot1 e l l0 => HOccursNot2 False e l l0 -- --------------------------------------------------------------------------
Data/HList/HSort.hs view
@@ -77,6 +77,9 @@ instance HEqByFn le => HIsAscList le '[x] True instance HEqByFn le => HIsAscList le '[] True instance (HEqBy le x y b1,+#if __GLASGOW_HASKELL__ > 906+ HEqByFn le,+#endif HIsAscList le (y ': ys) b2, HAnd b1 b2 ~ b3) => HIsAscList le (x ': y ': ys) b3 @@ -92,7 +95,8 @@ instance (SameLength a b, HIsAscList le a ok,- HSortBy1 ok le a b) => HSortBy le a b where+ HSortBy1 ok le a b,+ HEqByFn le) => HSortBy le a b where hSortBy = hSortBy1 (Proxy :: Proxy ok) instance HSortBy1 True le a a where@@ -129,7 +133,7 @@ instance HEqByFn le => HMSortBy le '[] '[] where hMSortBy _ x = x instance HEqByFn le => HMSortBy le '[x] '[x] where hMSortBy _ x = x-instance (HSort2 b x y ab, HEqBy le x y b) =>+instance (HSort2 b x y ab, HEqBy le x y b, HEqByFn le) => HMSortBy le '[x,y] ab where hMSortBy _ (a `HCons` b `HCons` HNil) = hSort2 (Proxy :: Proxy b) a b @@ -143,6 +147,9 @@ hSort2 _ x y = y `HCons` x `HCons` HNil instance (HMerge le xs' ys' sorted,+#if __GLASGOW_HASKELL__ > 906+ HEqByFn le,+#endif HMSortBy le ys ys', HMSortBy le xs xs', HLengthEq (a ': b ': c ': cs) n2,@@ -208,7 +215,7 @@ -} class HEqByFn lt => HSetBy lt (ps :: [*])-instance (HSortBy lt ps ps', HAscList lt ps') => HSetBy lt ps+instance (HEqByFn lt, HSortBy lt ps ps', HAscList lt ps') => HSetBy lt ps class HSetBy (HNeq HLeFn) ps => HSet (ps :: [*]) instance HSetBy (HNeq HLeFn) ps => HSet ps@@ -228,19 +235,23 @@ instance HIsSetBy (HNeq HLeFn) ps b => HIsSet ps b class HEqByFn lt => HIsSetBy lt (ps :: [*]) (b :: Bool) | lt ps -> b-instance (HSortBy lt ps ps', HIsAscList lt ps' b) => HIsSetBy lt ps b+instance (HEqByFn lt, HSortBy lt ps ps', HIsAscList lt ps' b) => HIsSetBy lt ps b -- | @HAscList le xs@ confirms that xs is in ascending order, -- and reports which element is duplicated otherwise. class HEqByFn le => HAscList le (ps :: [*]) -instance HAscList0 le ps ps => HAscList le ps+instance (HEqByFn le, HAscList0 le ps ps) => HAscList le ps class HEqByFn le => HAscList0 le (ps :: [*]) (ps0 :: [*]) class HEqByFn le => HAscList1 le (b :: Bool) (ps :: [*]) (ps0 :: [*])-instance (HAscList1 le b (y ': ys) ps0, HEqBy le x y b)+instance ( HAscList1 le b (y ': ys) ps0, HEqBy le x y b+#if __GLASGOW_HASKELL__ > 906+ , HEqByFn le+#endif+ ) => HAscList0 le (x ': y ': ys) ps0 instance HEqByFn le => HAscList0 le '[] ps0 instance HEqByFn le => HAscList0 le '[x] ps0
Data/HList/HZip.hs view
@@ -98,7 +98,7 @@ instance HZip3 '[] '[] '[] where hZip3 _ _ = HNil -instance (HList (x ': y) ~z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where+instance (HList (x ': y) ~ z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where hZip3 (HCons x xs) (HCons y ys) = HCons x y `HCons` hZip3 xs ys data HZipF = HZipF
Data/HList/Label5.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} #endif+#if __GLASGOW_HASKELL__ > 906+{-# LANGUAGE LambdaCase #-}+#endif {- | Description: labels are any instance of Typeable @@ -33,7 +36,7 @@ -- | Show label instance {-# OVERLAPPABLE #-} Typeable (x :: *) => ShowLabel x where- showLabel _ = (\(x:xs) -> toLower x:xs)+ showLabel _ = (\l -> case l of [] -> [] ; (x:xs) -> toLower x:xs) . reverse . takeWhile (not . (==) '.') . reverse
Data/HList/Labelable.hs view
@@ -33,7 +33,7 @@ LabeledCxt1, LabeledTo(LabeledTo), LabeledR(LabeledR),- ToSym(toLabel),+ ToSym, EnsureLabel(toLabel), toLabelSym, Identity, LabelableTIPCxt, LabeledOpticType(..),@@ -112,12 +112,24 @@ data LabeledR (x :: [*]) = LabeledR +{- if __GLASGOW_HASKELL__ > 800+-- should this orphan instance really be supplied? ghc 8's+-- -XOverloadedLabels is uglier syntax than HListPP, and it+-- seems likely that other users of IsLabel probably define+-- an instance for (->) which will be chosen over this one+-- when labels are composed with (.),+-- (or alternatively there will be complaints about overlap)+instance (x ~ x', Labelable x r s t a b) => IsLabel x (LabeledOptic x' r s t a b) where+ fromLabel _ = hLens' (Label :: Label x)+-- endif+-} + -- | make a @Lens (Record s) (Record t) a b@ instance HLens x Record s t a b => Labelable x Record s t a b where type LabelableTy Record = LabelableLens- hLens' = hLens+ hLens' x = hLens x -- | used with 'toLabel' and/or '.==.' instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where@@ -138,9 +150,12 @@ -- -- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@, -- cannot have an instance of Labelable-instance (TICPrism s t a b, x ~ a, a ~ b, s ~ t,+--+-- Note: `x :: k` according to the instance head, but the instance body+-- forces the kind variable to be * later on. IE. (k ~ *)+instance (TICPrism s t a b, Label x ~ Label a,a ~ b, s ~ t, SameLength s t) =>- Labelable (x :: *) TIC s t a b where+ Labelable (x :: k) TIC s t a b where type LabelableTy TIC = LabelablePrism hLens' _ = ticPrism @@ -150,12 +165,12 @@ -- 'tipyLens' provides a @Lens (TIP s) (TIP t) a b@, which tends to need -- too many type annotations to be practical instance LabelableTIPCxt x s t a b =>- Labelable x TIP s t a b where+ Labelable (x :: k) TIP s t a b where type LabelableTy TIP = LabelableLens- hLens' = hLens+ hLens' x = hLens x type LabelableTIPCxt x s t a b =- (s ~ t, a ~ b, x ~ a,+ (s ~ t, a ~ b, Label x ~ Label a, HLens x TIP s t a b) @@ -167,25 +182,40 @@ infixr 4 .==. +-- | Get the Symbol out of a 'Label' or 'LabeledTo'+class ToSym label (s :: Symbol) | label -> s -{- | Create a @'Label' (x :: 'Symbol')@:+instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3+ => ToSym (v1 v2 v3) x -> toLabel :: LabeledTo x _ _ -> Label x+instance ToSym (label x) x++{- | Convert a type to @Label :: Label blah@++> toLabel :: LabeledTo x _ _ -> Label (x :: Symbol)+> toLabel (hLens' lx) = (lx :: Label x) > toLabel :: Label x -> Label x > toLabel :: Proxy x -> Label x -}-class ToSym label (s :: Symbol) | label -> s where- toLabel :: label -> Label s+class EnsureLabel x y | x -> y where+ toLabel :: x -> y -instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3- => ToSym (v1 v2 v3) x where- toLabel _ = Label+instance EnsureLabel (Label x) (Label (x :: k)) where+ toLabel _ = Label -instance ToSym (label x) x where- toLabel _ = Label+instance EnsureLabel (Proxy x) (Label (x :: k)) where+ toLabel _ = Label +-- | get the Label out of a 'LabeledTo' (ie. `foobar when using HListPP).+instance ToSym (a b c) (x :: Symbol) => EnsureLabel (a b c) (Label x) where+ toLabel _ = Label ++-- | fix the `k` kind variable to 'Symbol'+toLabelSym label = toLabel label `asTypeOf` (Label :: Label (x :: Symbol))++ {- $comparisonWithhLensFunction Note that passing around variables defined with 'hLens'' doesn't get@@ -206,7 +236,7 @@ > -- with the x defined as x = Label :: Label "x" > let f x r = let > a = r ^. hLens x- > b = r & hLens x .~ "6"+ > b = r & hLens x .~ "7" > in (a,b) It may work to use 'hLens'' instead of 'hLens' in the second code,@@ -281,7 +311,7 @@ @Prism' (Variant s) (Variant a)@ -}-projected' s = simple (projected (simple s))+projected' s = isSimple projected s {- | Together with the instance below, this allows writing
Data/HList/MakeLabels.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {- | Description : Automate some of the ways to make labels.@@ -34,7 +35,14 @@ c = make_cname n d = make_dname n - dd = dataD (return []) c [] [] [''Typeable]+ dd =+#if MIN_VERSION_template_haskell(2,12,0)+ dataD (return []) c [] Nothing [] [derivClause Nothing [ [t| Typeable |] ]]+#elif MIN_VERSION_template_haskell(2,11,0)+ dataD (return []) c [] Nothing [] (fmap (:[]) [t| Typeable |])+#else+ dataD (return []) c [] [] [''Typeable]+#endif labelSig = sigD d [t| Label $(conT c) |]
Data/HList/Record.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP #-} {- | The HList library @@ -150,7 +150,9 @@ -- * Unclassified -- | Probably internals, that may not be useful+#if __GLASGOW_HASKELL__ != 706 zipTagged,+#endif HasField'(..), DemoteMaybe, HasFieldM1(..),@@ -196,7 +198,9 @@ import LensDefs import Data.Array (Ix)-+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif -- imports for doctest/examples import Data.HList.Label6 () import Data.HList.TypeEqO ()@@ -246,6 +250,7 @@ newtype Record (r :: [*]) = Record (HList r) +deriving instance Semigroup (HList r) => Semigroup (Record r) deriving instance Monoid (HList r) => Monoid (Record r) deriving instance (Eq (HList r)) => Eq (Record r) deriving instance (Ord (HList r)) => Ord (Record r)@@ -261,7 +266,7 @@ hListRecord x = isoNewtype mkRecord (\(Record r) -> r) x -- | @Iso' (HList s) (Record s)@-hListRecord' x = simple (isoNewtype Record (\(Record r) -> r) x)+hListRecord' x = isSimple hListRecord x -- | Build an empty record emptyRecord :: Record '[]@@ -322,7 +327,7 @@ -- | @Iso' (Record s) (Record a)@ -- -- such that @RecordValuesR s ~ RecordValuesR a@-relabeled' x = simple (relabeled x)+relabeled' x = isSimple relabeled x data TaggedFn = TaggedFn instance (tx ~ Tagged t x) => ApplyAB TaggedFn x tx where@@ -400,7 +405,8 @@ instance RecordValues '[] where type RecordValuesR '[] = '[] recordValues' _ = HNil-instance RecordValues r=> RecordValues (Tagged l v ': r) where+instance (SameLength' r (RecordValuesR r),+ SameLength' (RecordValuesR r) r, 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) @@ -465,7 +471,16 @@ instance (HMapCxt HList ReadComponent (AddProxy rs) bs, ApplyAB ReadComponent (Proxy r) readP_r, HProxies rs,- HSequence ReadP (readP_r ': bs) (r ': rs)) => Read (Record (r ': rs)) where+ HSequence ReadP (readP_r ': bs) (r ': rs),+ readP_r ~ ReadP (Tagged l v),++ -- ghc-8.0.2 needs these. The above constraints+ -- should imply them+ r ~ Tagged l v,+ ShowLabel l,+ Read v,+ HSequence ReadP bs rs+ ) => Read (Record (r ': rs)) where readsPrec _ = readP_to_S $ do _ <- string "Record{" content <- hSequence parsers@@ -589,7 +604,8 @@ hLookupByLabel l (Record r) = hLookupByLabel' (Proxy::Proxy b) l r -instance Fail (FieldNotFound l) => HasField l (Record '[]) (FieldNotFound l) where+-- | XXX+instance (t ~ Any, Fail (FieldNotFound l ())) => HasField l (Record '[]) t where hLookupByLabel _ _ = error "Data.HList.Record.HasField: Fail instances should not exist" @@ -724,7 +740,8 @@ => HUpdateAtLabel2 l v (Tagged l' e ': xs) xs' where hUpdateAtLabel2 = hUpdateAtLabel1 (Proxy :: Proxy b) -instance Fail (FieldNotFound l) => HUpdateAtLabel2 l v '[] '[] where+-- | XXX+instance Fail (FieldNotFound l ()) => HUpdateAtLabel2 l v '[] '[] where hUpdateAtLabel2 _ _ r = r @@ -825,6 +842,8 @@ h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout) where (rin,rout) = h2projectByLabels (Proxy::Proxy ls1) r +-- | if ls above has labels not in the record,+-- we get labels (rin `isSubsetOf` ls). instance H2ProjectByLabels ls r rin rout => H2ProjectByLabels' 'Nothing ls (f ': r) rin (f ': rout) where h2projectByLabels' _ ls (HCons x r) = (rin, HCons x rout)@@ -1055,7 +1074,7 @@ {- | @Iso' (r s) (r a)@ where @s@ is a permutation of @a@ -}-rearranged' x = simple (rearranged (simple x))+rearranged' x = isSimple rearranged x -- | Helper class for 'hRearrange' class (HRearrange3 ls r r', LabelsOf r' ~ ls,@@ -1094,8 +1113,8 @@ hRearrange4 _ ls (HCons lv@(Tagged v) _HNil) rout = HCons (Tagged v `asTypeOf` lv) (hRearrange3 ls rout) --- | For improved error messages-instance Fail (FieldNotFound l) =>+-- | For improved error messages. XXX FieldNotFound+instance Fail (FieldNotFound l ()) => HRearrange4 l ls '[] rout '[] where hRearrange4 _ _ _ _ = error "Fail has no instances" @@ -1234,20 +1253,11 @@ hUnzip = hUnzipRecord -instance (RecordValuesR lvs ~ vs,- SameLabels ls lvs,- LabelsOf lvs ~ ls,- SameLengths [ls,vs,lvs],- HAllTaggedLV lvs)- => HUnzip Proxy ls vs lvs where- hUnzip _ = (Proxy, Proxy)--instance HUnzip Proxy ls vs lvs- => HZip Proxy ls vs lvs where- hZip _ _ = Proxy-+#if __GLASGOW_HASKELL__ != 706+{- | Missing from ghc-7.6, because HZip Proxy instances interfere with HZip+HList instances. -{- | a variation on 'hZip' for 'Proxy', where+a variation on 'hZip' for 'Proxy', where the list of labels does not have to include Label (as in @ts'@) @@ -1275,6 +1285,7 @@ HZip Proxy lts vs tvs) => Proxy ts -> proxy vs -> Proxy tvs zipTagged _ _ = Proxy+#endif
Data/HList/RecordPuns.hs view
@@ -36,16 +36,18 @@ [@nesting@] -Nesting is supported. The idea is that variables inside-@{ }@ are in another record. More concretely:+Nesting is supported. Variables inside+@{ }@ and @( )@ are one level deeper, like the built-in syntax.+Furthermore the outer @{ }@ can be left out because @[pun|{x}|]@ is more+cluttered than @[pun|x|]@.+More concretely the pattern: -> [pun| ab@{ a b } y z c{d} |] -as a pattern, it will bindings from an original record @x@,-if you interpret (.) as a left-associative field lookup (as it-is in other languages):+> let [pun| ab@{ a b } y z c{d} |] = x -> let ab = xab+is short for:++> let ab = x.ab > a = x.ab.a > b = x.ab.b > y = x.y@@ -53,27 +55,45 @@ > -- c is not bound > d = x.c.d -as an expression, it creates a new record which needs the variables-@ab a b y z d@ in-scope. @ab@ needs to be a record, and if it has-fields called @a@ or @b@ they are overridden by the values of @a@ and @b@-which are in scope.+Where here `.` is a left-associative field lookup (as it is in other languages). -@( )@ 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+The pun quasiquoter can also be used in an expression context: -> [pun| (x _ y{}) |] = list+> let mkX ab a b y z d = [pun| ab@{ a b } y z c{d} |]+> x = mkX ab b y z d++Here `mkX` includes @ab a b y z d@. @ab@ needs to be a record, and if it has+fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ (via+'hLeftUnion' = '.<++.') . In other words,++> let mkX ab_ a b y z d = let ab = [pun| a b |] .<++. ab_+> in [pun| ab y z c{d} |]++For patterns, any order and additional fields are allowed if @{ }@ is used,+just as in built-in record syntax. But it is often necessary to restrict the+order and number of fields, such as if the record is a 'hRearrange' of a 'hLeftUnion'.+So use @( )@ instead:++> let [pun| (x _ y{}) |] = list > -- desugars to something like: > Record ((Tagged x :: Tagged "x" s1) `HCons` > (Tagged _ :: Tagged t s2) `HCons` > (Tagged _ :: Tagged "y" s3) `HCons` > HNil) = list -Where the @s1@ and @s2@ are allowed to fit whatever is in the HList. Note that this also introduces the familiar wild card pattern (@_@), and shows again how to ensure a label is present but not bind a variable to it. +For comparison, here are three equivalent ways to define variables `x` and `y`++> let [pun| x y{} |] = r+> let [pun|{ x y{} }|] = r -- or this+> let x = r .!. (Label :: Label "x")+> y = constrainType (r .!. (Label :: Label "y"))+> constrainType :: Record t -> Record t+> constrainType = id+ See also @examples/pun.hs@. In @{}@ patterns, @pun@ can work with 'Variant' too. @@ -98,33 +118,18 @@ suppressWarning f (V a) = f (C [V a]) suppressWarning f x = f x --- like \x -> (x .!. x1, x .!. x2)+-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2),+-- where x1 = Label :: Label "x1" extracts xs = do record <- newName "record"- let val = tupE+ -- to fix #5 I could comment out the ensureLength below+ lamE [varP record] $ tupE [ [| $(varE record) .!. $label |] | x <- xs, let label = [| Label :: Label $(litT (strTyLit x)) |], x /= "_" ] - -- constrain the type of the supplied record to have at least- -- as many elements as are extracted. In other words:- --- -- > f :: r (e1 ': e2 ': e3 ': e4 ': es) -> () -- is inferred- -- > f [pun| { _ _ _ _ } |] = ()- ensureLength = [| $(varE record) `asTypeOf` $(minLen xs) |]-- lamE [varP record] [| $val `const` $ensureLength |]----- | generates an @undefined :: r xs@, such that @xs :: [k]@ has--- at least as long as the input list-minLen :: [t] -> ExpQ-minLen [] = [| error "Data.HList.RecordPuns.minLen" :: r (es :: [*]) |]-minLen (_ : xs) = [| (error "Data.HList.RecordPuns.minLen"- :: r es -> r (e ': es)) $(minLen xs) |]- mkPair :: String -> ExpQ -> ExpQ mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |] @@ -154,7 +159,7 @@ mp (D as) = conP 'Record- [(foldr ( \ (n,p) xs -> conP 'HCons+ [foldr ( \ (n,p) xs -> conP 'HCons [ let ty | n == "_" = [| undefined :: Tagged anyLabel t |] | otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |]@@ -162,7 +167,7 @@ (conP 'Tagged [p]), xs]) (conP 'HNil [])- (mps as))]+ (mps as)] mp a = do reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a mp (C [a])
Data/HList/RecordU.hs view
@@ -16,7 +16,6 @@ import Data.HList.Labelable import Unsafe.Coerce-import GHC.Exts (Any) -- * Type definitions -- ** RecordUS@@ -195,7 +194,7 @@ -- ** with the actual representation --- | @Iso (HList s) (HList t) (RecordUS a) (Record b)@+-- | @Iso (HList s) (HList t) (RecordUS a) (RecordUS b)@ recordUS r = iso hListToRecordUS recordUSToHList r {- | @Iso (HList s) (RecordUS a)@@@ -204,7 +203,7 @@ is list of @Tagged label value@ -}-recordUS' r = simple (recordUS r)+recordUS' r = isSimple recordUS r -- ** with 'Record' @@ -239,7 +238,7 @@ unboxedS r = iso recordToRecordUS recordUSToRecord r -- | @Iso' (Record x) (RecordUS x)@-unboxedS' r = simple (unboxedS r)+unboxedS' r = isSimple unboxedS r @@ -327,7 +326,7 @@ unboxed r = iso recordToRecordU recordUToRecord r -- | @Iso' (Record x) (RecordU x)@-unboxed' x = simple (unboxed x)+unboxed' x = isSimple unboxed x class RecordToRecordU x where@@ -340,7 +339,7 @@ HLengthEq x n, IArray UArray (GetElemTy x) ) => RecordToRecordU x where- recordToRecordU (rx @ (Record x)) = RecordU $ listArray+ recordToRecordU (rx@(Record x)) = RecordU $ listArray (0, hNat2Integral (hLength x) - 1) (hList2List (recordValues rx)) @@ -423,11 +422,13 @@ HLensCxt x RecordU s t a b) => Labelable x RecordU s t a b where type LabelableTy RecordU = LabelableLens- hLens' = hLens+ hLens' x = hLens x {- TODO instance Labelable x RecordUS to p f s t a b where instance (r ~ r', HasField l (Record r) v) => HUpdateAtLabel RecordUS l v r r' where hUpdateAtLabel = error "recordus hupdateatlabel"++Benchmarks -}
Data/HList/TIC.hs view
@@ -24,7 +24,9 @@ import Data.HList.HArray import Data.Array (Ix)-+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif import Text.ParserCombinators.ReadP import LensDefs @@ -41,6 +43,7 @@ deriving instance Bounded (Variant l) => Bounded (TIC l) deriving instance Enum (Variant l) => Enum (TIC l) deriving instance Monoid (Variant l) => Monoid (TIC l)+deriving instance Semigroup (Variant l) => Semigroup (TIC l) instance HMapAux Variant f xs ys => HMapAux TIC f xs ys where@@ -52,7 +55,7 @@ ticVariant x = isoNewtype (\(TIC a) -> a) TIC x -- | @Iso' (TIC s) (Variant s)@-ticVariant' x = simple (ticVariant x)+ticVariant' x = isSimple ticVariant x -- --------------------------------------------------------------------------@@ -108,7 +111,7 @@ where @s@ has a type like @'[Tagged \"x\" Int]@, and @a@ has a type like @'[Tagged Int Int]@. -}-typeIndexed' x = simple (typeIndexed x)+typeIndexed' x = isSimple typeIndexed x -- -------------------------------------------------------------------------- -- | Public constructor (or, open union's injection function)
Data/HList/TIP.hs view
@@ -20,11 +20,17 @@ import Data.HList.HList import Data.HList.Record import Data.HList.HTypeIndexed ()-import Data.HList.HOccurs import Data.HList.TIPtuple import Data.List (intercalate) import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif +#if __GLASGOW_HASKELL__ > 710+import Data.Coerce+#endif+ import LensDefs -- --------------------------------------------------------------------------@@ -34,6 +40,7 @@ -- has type @Tagged e_i e_i@ newtype TIP (l :: [*]) = TIP{unTIP:: HList l} +deriving instance Semigroup (HList a) => Semigroup (TIP a) deriving instance Monoid (HList a) => Monoid (TIP a) deriving instance Eq (HList a) => Eq (TIP a) deriving instance (Ord (HList r)) => Ord (TIP r)@@ -134,9 +141,9 @@ -- | provides a @Lens' (TIP s) a@. 'hLens'' @:: Label a -> Lens' (TIP s) a@ -- is another option. #if __GLASGOW_HASKELL__ < 707-tipyLens' x = simple (tipyLens x) -- rejected by GHC-7.10RC1+tipyLens' x = isSimple tipyLens x -- rejected by GHC-7.10RC1 #else-tipyLens' f s = simple (hLens x f) (asTIP s) -- rejected by GHC-7.6.3+tipyLens' f s = isSimple (hLens x) f (asTIP s) -- rejected by GHC-7.6.3 where x = getA f getA :: (a -> f a) -> Label a@@ -152,16 +159,31 @@ ambiguity as to which field \"a\" should actually be updated. -}-tipyLens f s = hLens x f (asTIP s)+tipyLens f (TIP s) =+ case hSplitAt (getN s f) (ghc8fix1 s) of+ (x, ta@(Tagged a) `HCons` ys)+ | () <- ghc8fix2 ta ->+ let mkt b = mkTIP (x `hAppendList` (tagSelf b `HCons` ys))+ in mkt <$> f a where- x = getA f- getA :: (a -> f b) -> Label a- getA _ = Label+ getN :: HFind (Label a) (LabelsOf s) n => HList s -> (a -> f b) -> Proxy n+ getN _ _ = Proxy - asTIP :: TIP a -> TIP a- asTIP = id+ -- without these, tipyLens has a type that has kind variables,+ -- (that end up being * when an actual TIP is provided), leading to+ -- a Properties.LengthIndependent compile error:+ -- .../.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/Data/HList/TIP.hi+ -- Declaration for tipyLens:+ -- Iface type variable out of scope: k+ -- Cannot continue after interface file error+ ghc8fix1 :: HList (Tagged x x ': xs) -> HList (Tagged x x ': xs)+ ghc8fix1 = id + ghc8fix2 :: Tagged a a -> ()+ ghc8fix2 _ = () ++ -- | The same as 'tipyProject', except also return the -- types not requested in the @proxy@ argument tipyProject2 ps (TIP l) = (mkTIP l',mkTIP l'')@@ -242,7 +264,7 @@ -- | Sometimes the type variables available have @TagR@ already applied -- (ie the lists have elements like @Tagged X X@). Then this abbreviation -- is useful:-type UntagTag xs = TagUntagFD (UntagR xs) xs+type UntagTag xs = (TagR (UntagR xs) ~ xs, TagUntagFD (UntagR xs) xs) type family TagR (a :: [*]) :: [*] type family UntagR (ta :: [*]) :: [*]@@ -261,7 +283,7 @@ tipHList x = iso (\(TIP a) -> hUntagSelf a) (TIP . hTagSelf) x -- | @Iso' (TIP (TagR s)) (HList a)@-tipHList' x = simple (tipHList x)+tipHList' x = isSimple tipHList x -- * conversion to and from 'Record'@@ -272,11 +294,13 @@ tipRecord x = isoNewtype (\(TIP a) -> Record a) (\(Record b) -> TIP b) x -- | @Iso' (TIP (TagR s)) (Record a)@-tipRecord' x = simple (tipRecord x)+tipRecord' x = isSimple tipRecord x -- -------------------------------------------------------------------------- -- * Zip +#if __GLASGOW_HASKELL__ < 800+-- pre-coerce instance (HZipList (UntagR x) (UntagR y) (UntagR xy), UntagTag x, UntagTag y, UntagTag xy, SameLengths [x,y,xy],@@ -295,6 +319,31 @@ SameLengths [x,y,xy]) => HUnzip TIP x y xy where hUnzip = hUnzipTIP +#else+-- ghc-7.10.3 has coerce, but rejects these instances+instance (HZipList xL yL xyL,+ lty ~ (HList xyL -> (HList xL,HList yL)),+ Coercible lty (TIP xy -> (TIP x, TIP y)),+ UntagR x ~ xL, TagR xL ~ x, -- `TagR (UntagR x) ~ x` included by UntagTag+ UntagR y ~ yL, TagR yL ~ y,+ UntagR xy ~ xyL, TagR xyL ~ xy,+ SameLengths '[x,y,xy],+ UntagTag x, UntagTag y, UntagTag xy+ ) => HUnzip TIP x y xy where+ hUnzip = coerce (hUnzipList :: lty)++instance (HUnzip TIP x y xy,+ HZipList xL yL xyL,+ lty ~ (HList xL -> HList yL -> HList xyL),+ Coercible lty (TIP x -> TIP y -> TIP xy) ,+ UntagR x ~ xL,+ UntagR y ~ yL,+ UntagR xy ~ xyL,+ UntagTag x, UntagTag y, UntagTag xy+ ) => HZip TIP x y xy where+ hZip = coerce (hZipList :: lty)+#endif+ -- | specialization of 'hZip' hZipTIP (TIP x) (TIP y) = TIP (hTagSelf (hZipList (hUntagSelf x) (hUntagSelf y))) @@ -350,8 +399,9 @@ => TransTIP1 False (HSucc n) (arg -> op) db where ttip1 _ _ = ttip2 (Proxy :: Proxy b) -instance Fail '(TypeNotFound notfun, "in TIP", db) => TransTIP1 False HZero notfun db where- ttip1 = error "TransTIP1 Fail must have no instances"+instance Fail (FieldNotFound notfun (TIP db))+ => TransTIP1 False HZero notfun db where+ ttip1 = error "TransTIP1 Fail failed" class TransTIP2 (b :: Bool) arg op db where ttip2 :: Proxy b -> (arg -> op) -> TIP db -> TIP db@@ -361,8 +411,9 @@ => TransTIP2 True arg op db where ttip2 _ f db = ttip (f (hOccurs db)) db -instance Fail '(TypeNotFound arg, "in TIP", db) => TransTIP2 False arg op db where- ttip2 = error "TransTIP2 Fail must have no instances"+instance Fail (FieldNotFound arg (TIP db))+ => TransTIP2 False arg op db where+ ttip2 = error "TransTIP2 Fail failed" -- ** Monadic version @@ -400,9 +451,9 @@ op' <- op return $ tipyUpdate op' db -instance (Fail '(TypeNotFound op, "in TIP", db), Monad m)+instance (Fail (FieldNotFound op (TIP db)), Monad m) => TransTIPM1 False HZero m op db where- ttipM1 _ _ = error "TransTIPM1 Fail must have no instances"+ ttipM1 _ _ = error "TransTIPM1 Fail failed" -- If op is not found in a TIP, it must be a function. Look up -- its argument in a TIP and recur.@@ -421,9 +472,9 @@ ttipM2 _ f db = ttipM (f (hOccurs db)) db -instance (Fail '(TypeNotFound op, "in TIP", db))+instance Fail (FieldNotFound op (TIP db)) => TransTIPM2 False m arg op db where- ttipM2 _ _ = error "TransTIPM1 Fail must have no instances"+ ttipM2 _ _ = error "TransTIPM1 Fail failed" -- --------------------------------------------------------------------------
Data/HList/Variant.hs view
@@ -27,9 +27,10 @@ import Text.ParserCombinators.ReadP hiding (optional) import Unsafe.Coerce-import GHC.Prim (Any) import GHC.Exts (Constraint)-+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup( .. ))+#endif import Data.Data import Control.Applicative import LensDefs@@ -738,6 +739,8 @@ instance (HUnzip Variant (x2 ': xs) (y2 ': ys) (xy2 ': xys),+ SameLength xs ys,+ SameLength ys xys, tx ~ Tagged t x, ty ~ Tagged t y, txy ~ Tagged t (x,y))@@ -911,22 +914,36 @@ -- * Ix (TODO) +-- * Semigroup+instance (Unvariant '[Tagged t x] x, Semigroup x) => Semigroup (Variant '[Tagged t x]) where+ a <> b = case (unvariant a, unvariant b) of+ (l, r) -> mkVariant (Label :: Label t) (l <> r) Proxy +instance (Semigroup x, Semigroup (Variant (a ': b))) => Semigroup (Variant (Tagged t x ': a ': b)) where+ a <> b = case (splitVariant1 a, splitVariant1 b) of+ (Left l, Left r) -> mkVariant (Label :: Label t) (l <> r) Proxy+ (Left l, _) -> mkVariant (Label :: Label t) l Proxy+ (_, Left r) -> mkVariant (Label :: Label t) r Proxy+ (Right l, Right r) -> extendVariant $ l <> r+ -- * Monoid instance (Unvariant '[Tagged t x] x, Monoid x) => Monoid (Variant '[Tagged t x]) where mempty = mkVariant (Label :: Label t) mempty Proxy+#if __GLASGOW_HASKELL__ <= 906 mappend a b = case (unvariant a, unvariant b) of (l, r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+#endif --- | XXX check this mappend is legal instance (Monoid x, Monoid (Variant (a ': b))) => Monoid (Variant (Tagged t x ': a ': b)) where mempty = extendVariant mempty+#if __GLASGOW_HASKELL__ <= 906 mappend a b = case (splitVariant1 a, splitVariant1 b) of (Left l, Left r) -> mkVariant (Label :: Label t) (mappend l r) Proxy (Left l, _) -> mkVariant (Label :: Label t) l Proxy (_, Left r) -> mkVariant (Label :: Label t) r Proxy (Right l, Right r) -> extendVariant $ mappend l r+#endif -- * Projection
− Data/HList/broken/VariantOld.hs
@@ -1,68 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-}---{- |- The HList library-- (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke-- Variants, i.e., labelled sums.-- One approach to their implementation would be to consider both- the favoured label and the corresponding value as dynamics upon- variant construction. Since we are too lazy to programme some- Typeable instances for non-ghc systems (NB: in GHC, Typeable- is derivable), we rather model variants as (opaque) records- with maybies for the values. Only one value will actually hold- non-Nothing, as guaranteed by the constructor.-- See VariantP.hs for a different approach to open sums.--}--module Data.HList.Variant where--import Data.HList.FakePrelude-import Data.HList.Record-import Data.HList.HList----- ----------------------------------------------------------------------------- | Variant types on the basis of label-maybe pairs.--newtype Variant mr = Variant mr----- ----------------------------------------------------------------------------- | Turn proxy sequence into sequence of Nothings--data HMaybeF = HMaybeF-instance ((Tagged l (Proxy t) ~ a, b ~ Tagged l (Maybe t))) => ApplyAB HMaybeF a b where- applyAB _ _ = Tagged Nothing--hMaybied x = hMap HMaybeF x----- ----------------------------------------------------------------------------- | Public constructor--- it seems we can blame 'hUpdateAtLabel' (not 'HMap') for needing the asTypeOf?-mkVariant x y (Record v) = let r1 = Record (hMaybied v) in- case hUpdateAtLabel x (Just y) r1 `asTypeOf` r1 of- Record t -> Variant t---- ----------------------------------------------------------------------------- | Public destructor--unVariant x (Variant v) = hLookupByLabel x (Record v)----- ----------------------------------------------------------------------------- | Variants are opaque--instance Show (Variant v)- where- show _ = "<Cannot show Variant content!>"--
HList.cabal view
@@ -1,5 +1,5 @@ Name: HList-Version: 0.4.2.0+Version: 0.5.4.0 Category: Data Synopsis: Heterogeneous lists Description: HList provides many operations to create and manipulate@@ -7,13 +7,21 @@ types are known at compile-time. HLists are used to implement . * records+ . * variants+ . * type-indexed products (TIP)+ . * type-indexed co-products (TIC)+ . * keyword arguments . User code should import "Data.HList" or "Data.HList.CommonMain" for a slightly more limited scope+ .+ The original design is described in <http://okmij.org/ftp/Haskell/HList-ext.pdf>,+ though since that paper came out, the -XTypeFamiles extension has been used to+ replace `TypeCast` with `~`. License: MIT License-File: LICENSE Author: 2004 Oleg Kiselyov (FNMOC, Monterey), Ralf Laemmel (CWI/VU, Amsterdam),@@ -22,25 +30,20 @@ Data-files: README, ChangeLog Cabal-version: >= 1.10-Tested-With: GHC==7.6.3, GHC==7.8.4, GHC==7.10.2+Tested-With: GHC==9.4.8, GHC==9.6.6, GHC==9.8.2, GHC==9.10.1 Build-Type: Simple Extra-Source-Files:- examples/*.hs,- examples/Properties/*.hs, examples/broken/*.hs, examples/broken/*.lhs,-- examples/*.ref,- examples/broken/*.ref, Data/HList/broken/*.hs, Data/HList/obsolete/*.hs Source-Repository head- type: darcs- location: http://code.haskell.org/HList+ type: git+ location: https://bitbucket.org/HList/hlist flag new_type_eq@@ -55,9 +58,11 @@ See <https://ghc.haskell.org/trac/ghc/ticket/9918> library- Build-Depends: base >= 4.6 && < 4.9,+ Build-Depends: base >= 4.6 && < 4.21, -- for Typeable '[] and '(:) with ghc-7.6 base-orphans,+ -- Data.Semigroup for ghc < 8+ semigroups, template-haskell, ghc-prim, mtl,@@ -69,6 +74,7 @@ Exposed-modules: Data.HList, Data.HList.CommonMain, Data.HList.Data,+ Data.HList.Dredge, Data.HList.FakePrelude, Data.HList.HArray, Data.HList.HCurry,@@ -119,7 +125,12 @@ Other-Extensions: CPP TemplateHaskell OverlappingInstances+ if impl(ghc >= 8.6)+ Default-Extensions: StarIsType + if impl(ghc >= 8.0)+ Default-Extensions: UndecidableSuperClasses+ if impl(ghc < 7.7) Cpp-options: -DOLD_TYPEABLE -DNO_CLOSED_TF @@ -129,41 +140,66 @@ if impl(ghc > 7.9) Ghc-Options: -fno-warn-unticked-promoted-constructors+ -Wno-star-is-type if flag(new_type_eq) Cpp-options: -DNEW_TYPE_EQ- Build-Depends: base >= 4.7+ Build-Depends: base >= 4.7 && < 4.21 Test-Suite examples Type: exitcode-stdio-1.0- Ghc-Options: -threaded- Main-Is: runexamples.hs+ Main-Is: HListExample.hs Default-Language: Haskell2010 Hs-Source-Dirs: examples- Build-Depends: base, hspec >= 1.7, directory, filepath,- process, syb, cmdargs, lens, HList, mtl+ Build-Depends: base < 4.21, hspec >= 1.7, directory, filepath,+ hspec-expectations,+ process,+ syb,+ cmdargs,+ lens,+ HList,+ mtl,+ QuickCheck,+ array,+ semigroups,+ template-haskell+ Other-Modules:+ Properties.Common++ HListExample.CmdArgs+ HListExample.Datatypes2+ HListExample.Labelable+ HListExample.MainGhcGeneric1+ HListExample.MainPosting051106+ HListExample.OverloadedLabels+ HListExample.Prism+ HListExample.Pun+ HListExample.TIPTransform+ HListExample.TIPTransformM+ if impl(ghc > 7.9) Ghc-Options: -fno-warn-tabs Test-Suite doctests Type: exitcode-stdio-1.0 Ghc-Options: -threaded- if impl(ghc <= 7.9)+ if impl(ghc <= 7.9 ) && impl(ghc <= 7.11) -- doctests include things like :t pred . maxBound, which -- depending on the ghc version, comes out as one of -- (Bounded a, Enum a) => ... -- (Enum b, Bounded b) => ...- Buildable: False+ Build-Depends: base < 4.21, doctest >= 0.8, process+ Buildable: False Main-Is: rundoctests.hs Hs-Source-Dirs: examples- Build-Depends: base, doctest >= 0.8, process Default-Language: Haskell2010 Test-Suite properties Type: exitcode-stdio-1.0- Build-Depends: base,+ Build-Depends: base < 4.21, hspec >= 1.7,+ hspec-expectations, HList, lens, mtl,@@ -171,6 +207,14 @@ template-haskell, array, syb+ Other-Modules:+ Properties.Common+ Properties.KW+ Properties.LengthDependent+ Properties.LengthDependentSplice+ Properties.LengthIndependent Main-Is: Properties.hs Hs-Source-Dirs: examples Default-Language: Haskell2010+ if impl(ghc <= 7.11)+ build-depends: semigroups
LensDefs.hs view
@@ -22,9 +22,25 @@ type Coercible a b = (() :: Constraint) #endif -simple :: p a (f a) -> p a (f a)-simple = id +type Equality' s a = forall p (f :: * -> *). a `p` f a -> s `p` f s++{- | if we write @f' = simple . f@, then the inferred type is++> f' :: (s ~ t, _) => Lens s t a b++which normally will let ghc figure out (a~b). However with the+types that come up in HList this can only be figure out with+concrete types, so we use isSimple instead which also specifies+(a~b).++-}+isSimple :: optic ~ (p a (f a) -> p s (f s)) => optic -> optic+isSimple = id+-- alternatively: isSimple x = simple . x . simple++simple :: Equality' a a+simple = id -- Used by doctests (which should probably just import Control.Lens...) infixl 1 &
README view
@@ -2,7 +2,7 @@ Contributors: Justin Bailey, Brian Bloniarz, Gwern Branwen, Einar Karttunen,- and Adam Vogt+ Daniil Iaitskov and Adam Vogt The HList library and samples@@ -11,18 +11,19 @@ Getting the code -> darcs get http://code.haskell.org/HList+> git clone https://bitbucket.org/HList/hlist HList ---------------------------------------------------------------------- Pushing changes -You need an account at code.haskell.org+You need an account at bitbucket.org > cd HList-> darcs pull user@code.haskell.org:/srv/darcs/HList-> darcs record-> darcs push+> git clone git@bitbucket.org:HList/hlist.git+> git pull+> git commit --interactive+> git push ---------------------------------------------------------------------- @@ -35,19 +36,35 @@ since doing so would have implied inclusion of substantial packages, namely the underlying infrastructure for database access library. -You can get HList from Hackage or from Darcs:+You can get HList from Hackage or from bitbucket: $ cabal update && cabal install HList Or: -$ darcs get --partial http://code.haskell.org/HList/+$ git clone https://bitbucket.org/HList/hlist HList $ cd HList; cabal install -The code works --- within the limits exercised in the source files ----for GHC-7.6 and GHC-7.8 and GHC-7.10. Older compilers are not supported.+The code was tested --- within the limits exercised in the source files ---+with GHC 9.4.8 through 9.10.1 and it may still work older versions possibly back to+GHC-7.6 +Older compilers are not supported.+ One may run "cabal test" to check the distribution. -See ChangeLog for updates.+---------------------------------------------------------------------- +The library can be built and tested in the checked environment (with+compatible GHC, cabal and dependencies) provided by nix:++$ nix-build # builds and runs tests+$ nix-shell --pure # drops into an isolated shell++nix usually can be installed with a single line:++$ sh <(curl -L https://nixos.org/nix/install) --no-daemon++----------------------------------------------------------------------++See ChangeLog for updates.
Setup.lhs view
@@ -1,114 +1,4 @@-#!/usr/bin/runhaskell-\begin{code}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where--import Language.Haskell.Extension- ( Extension(EnableExtension, UnknownExtension, DisableExtension) )-import Data.List ( nub )-import Data.Version ( showVersion )-import Distribution.Package- ( PackageName(PackageName),- PackageId,- InstalledPackageId,- packageVersion,- packageName )-import Distribution.PackageDescription ()-import Distribution.Simple- ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils- ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ()-import Distribution.Simple.LocalBuildInfo ()-import System.FilePath ( (</>) )-import Distribution.Verbosity ( Verbosity )-import Distribution.PackageDescription ()-import Distribution.Simple.LocalBuildInfo ()-import Distribution.PackageDescription- ( TestSuite(testName),- PackageDescription,- Library(libBuildInfo),- allExtensions )-import Distribution.Simple.Compiler ()-import Distribution.Simple.Setup- ( BuildFlags(buildVerbosity),- ConfigFlags(..),- Flag(Flag, NoFlag),- fromFlag )-import Distribution.Simple.LocalBuildInfo- ( LocalBuildInfo(configFlags),- ComponentLocalBuildInfo(componentPackageDeps),- withTestLBI,- withLibLBI )-import Data.Maybe--main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- }--generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule verbosity pkg lbi = do- let dir = autogenModulesDir lbi- createDirectoryIfMissingVerbose verbosity True dir- withLibLBI pkg lbi $ \ lib libcfg -> do- withTestLBI pkg lbi $ \suite suitecfg -> do- rewriteFile (dir </> "Build_" ++ testName suite ++ ".flags") $ unlines $- [ hc , unwords (formatdeps (testDeps libcfg suitecfg) ++ exts lib) ]- where- hc = case configHcPath (configFlags lbi) of- Flag a -> a- NoFlag -> fromMaybe "ghc" (lookup "ghc" (configProgramPaths (configFlags lbi)))- formatdeps = map (formatone . snd)- formatone p = case packageName p of- PackageName n -> "-package=" ++ n ++ "-" ++ showVersion (packageVersion p)-- exts lib = [ "-X" ++ se- | e <- allExtensions (libBuildInfo lib),- Just se <- [case e of- EnableExtension x -> Just (show x)- UnknownExtension x -> Just x- DisableExtension x -> Just ("No" ++ show x)- ]- ]--testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys---\end{code}-Adapted from:--Copyright 2012-2015 Edward Kmett--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 author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.+#!/usr/bin/env runhaskell -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR-ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,-STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN-ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.+> import Distribution.Simple+> main = defaultMain
− examples/Cabal.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE CPP #-}-module Cabal where--import System.Process-import System.Exit-import Control.Monad---- | > cabal args stdin = readProcessWithExitCode "cabal" args stdin------ except it also tries to runghc Setup which can succeed (because--- if things have been configured with runghc Setup, then a different--- version of the Cabal library is chosen and cabal complains instead--- of reconfiguring / using an older Cabal library-cabal :: [String] -> String- -> IO (ExitCode, String, String)-cabal args stdin = do-#if __GLASGOW_HASKELL__ > 707- cabalRepl @ (ec, _, _) <- readProcessWithExitCode "cabal" args stdin- if ec == ExitSuccess then return cabalRepl- else do- runghcRepl @ (ec2, _, _) <- readProcessWithExitCode "runghc" ("Setup.lhs":args) stdin- when (ec2 /= ExitSuccess) $ do- putStrLn "Could not \"cabal ...\" (exitCode,stdout,stderr):"- print cabalRepl- putStrLn "Could not \"runghc Setup ...\" (exitCode,stdout,stderr):"- print runghcRepl-- putStrLn "\"...\" above is "- putStrLn "Command:"- print ("cabal" : args)- putStrLn "stdin:"- print stdin- return ()-- return runghcRepl-#else- -- we don't have a cabal repl (at least if we're using the Cabal that ghc- -- comes with), so read a file written by the ./Setup build- "repl" : tgt : args <- return args- ghc : rest <- lines `fmap` readFile ("dist/build/autogen/Build_" ++ tgt ++ ".flags")- let args2 = "--interactive"- : "-v"- : "-package-db" : "dist/package.conf.inplace"- : concatMap words rest ++ args-- args3 = case break (=="--ghc-options") args2 of- (a, _:_:b) -> a ++ b- print args3- readProcessWithExitCode ghc args3 stdin-#endif
− examples/Datatypes1.hs
@@ -1,14 +0,0 @@-module Datatypes1 where---- The fout-n-mouth example--newtype Key = Key Integer- deriving (Show,Eq,Ord)-newtype Name = Name String- deriving (Show,Eq)-data Breed = Cow | Sheep- deriving (Show,Eq)-newtype Price = Price Float- deriving (Show,Eq,Ord)-data Disease = BSE | FM- deriving (Show,Eq)
− examples/Datatypes2.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Datatypes2 where--import Data.Typeable---- The fout-n-mouth example--- (deriving Typeable only supported for GHC)--newtype Key = Key Integer- deriving (Show,Eq,Ord,Typeable)-newtype Name = Name String- deriving (Show,Eq,Typeable)-data Breed = Cow | Sheep- deriving (Show,Eq,Typeable)-newtype Price = Price Float- deriving (Show,Eq,Ord,Typeable)-data Disease = BSE | FM- deriving (Show,Eq,Typeable)
− examples/FooBar.hs
@@ -1,27 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-{-# OPTIONS -fallow-undecidable-instances #-}-{-# OPTIONS -fallow-overlapping-instances #-}--data Foo x y-class Bar x y | x -> y-class Zoo x y | x -> y--{---Works for both GHC and Hugs--instance Bar (Foo x y) y-instance Bar (Foo (Foo x y) z) z---}--{---Works for GHC but not Hugs---}--instance Zoo x r => Bar (Foo x y) r-instance Zoo x r => Bar (Foo (Foo x y) z) r--
+ examples/HListExample.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- tests based on HListExample+module Main (main) where+++import Test.Hspec+++import HListExample.Labelable+import HListExample.CmdArgs+import HListExample.MainGhcGeneric1+-- import HListExample.MainPosting040607+import HListExample.MainPosting051106+import HListExample.Prism+import HListExample.Pun+import HListExample.TIPTransform+import HListExample.TIPTransformM+import HListExample.OverloadedLabels+++main = hspec $ do+ mainCmdargs+ mainLabelable+ mainGhcGeneric1+ mainPosting051106+ mainPrism+ mainPun+ mainTIPTransform+ mainTTIPM+ mainOverloadedLabels++++++
+ examples/HListExample/CmdArgs.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}+module HListExample.CmdArgs where+++import Data.Generics+import Control.Lens+import Test.Hspec+import Properties.Common++import Data.HList.CommonMain++import System.Console.CmdArgs (cmdArgs)+import System.Environment (withArgs)+++{-++An example showing off the data instance for Record / Variant / TIP / TIC++Also a use of cmdArgs++Note that ghc-7.8.2 does not have (or can produce) instances of typeable+for types of kind Symbol (ie. promoted strings):+<https://ghc.haskell.org/trac/ghc/ticket/9111>, so for now use the Label3+style++-}++#define USE_LABEL3 __GLASGOW_HASKELL__ == 708++#if USE_LABEL3+makeLabels3 "examples_cmdargs" (words "x y z tic")+makeLabels3 "optV" (words "optA optB optC")+#else+makeLabels6 (words "x y z tic")+makeLabels6 (words "optA optB optC")+#endif++makeLabelable "abc df"++#if USE_LABEL3+v = (optA .*. optB .*. optC .*. emptyProxy)+ `zipTagged` (Proxy :: Proxy '[Int,Char,Double])+#else+v = Proxy :: Proxy '[Tagged "optA" Int, Tagged "optB" Char, Tagged "optC" Double]+#endif++type Z' = TagR [Int, Char, Double]+-- type Z' = [Tagged Int Int, Tagged Char Char, Tagged Double Double]++d0 = x .=. (5 :: Int)+ .*. y .=. True+ .*. z .=. mkVariant optC (1 :: Double) v+ .*. tic .=. mkTIC' 'x' (Proxy :: Proxy Z')+ .*. emptyRecord++-- the equivalent ordinary record for reference+data E = E { a :: Int, b :: Bool }+ deriving (Show, Data, Typeable)++data Opt = OptA Int | OptB Char | OptC Double+ deriving (Show, Data, Typeable)++e0 = E 5 True++mainCmdargs = describe "cmdargs/Data" $ do+ it "variant show" $+ mkVariant optC 1 v `shouldShowTo` "V{optC=1.0}"++ -- increment V{optC=1.0} via data instance+ it "gmapT" $+ gmapT (mkT ((+1) :: Double -> Double)) (mkVariant optC 1 v)+ `shouldShowTo` "V{optC=2.0}"++ it "d0" $+ d0 `shouldShowTo`+ "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++ it "modify d0's Bool children" $+ gmapT (mkT not) d0 `shouldShowTo`+ "Record{x=5,y=False,z=V{optC=1.0},tic=TIC{char='x'}}"++ it "modify d0's Int children" $+ gmapT (mkT (+(1::Int))) d0 `shouldShowTo`+ "Record{x=6,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++ it "modify d0's Char children (none)" $+ gmapT (mkT (succ :: Char -> Char)) d0 `shouldShowTo`+ "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++ it "modify d0's Char grandchildren" $+ everywhere (mkT (succ :: Char -> Char)) d0 `shouldShowTo`+ "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='y'}}"++#if __GLASGOW_HASKELL__ != 706+ -- ghc-7.6.3 fails with all uses of dredge:+ -- Kind incompatibility when matching types:+ -- Const (Data.Monoid.First Double) Double :: AnyK+ -- Const (Data.Monoid.First Double) Double :: *++ it "dredge optC" $+ d0 & dredge optC +~ 1 `shouldShowTo`+ "Record{x=5,y=True,z=V{optC=2.0},tic=TIC{char='x'}}"+#endif++ -- theB is like a TIP the unsafe lookup function applied+ let theB :: Typeable a => a+ theB = error "theB"+ `extB` (1::Int)+ `extB` True+ `extB` (2.5::Double)+ `extB` 'b'+ `extB` mkVariant optC theB v+ `extB` mkTIC' (theB :: Char) (Proxy :: Proxy Z')++ it "fromConstrB" $+ fromConstrB theB undefined `asTypeOf` d0 `shouldShowTo`+ "Record{x=1,y=True,z=V{optC=2.5},tic=TIC{char='b'}}"++ it "cmdargs built-in data" $+ withArgs ["-a=4", "-b=False" ] (cmdArgs e0) `shouldReturnShowTo`+ "E {a = 4, b = False}"++ -- drop the tic and variant-containing fields: cmdargs doesn't support+ -- it. Cmdargs doesn't support fields containing+ -- `data Opt = OptA Int | OptB Char` either+ let dRec = d0 & from hListRecord %~ (hInit . hInit)++ it "dRec" $+ dRec `shouldShowTo`+ "Record{x=5,y=True}"++ it "cmdargs Record" $+ withArgs ["-x=4", "-y=False"] (cmdArgs dRec) `shouldReturnShowTo`+ "Record{x=4,y=False}"+
+ examples/HListExample/Datatypes2.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}++module HListExample.Datatypes2 where++import Data.Typeable++-- The fout-n-mouth example+-- (deriving Typeable only supported for GHC)++newtype Key = Key Integer+ deriving (Show,Eq,Ord,Typeable)+newtype Name = Name String+ deriving (Show,Eq,Typeable)+data Breed = Cow | Sheep+ deriving (Show,Eq,Typeable)+newtype Price = Price Float+ deriving (Show,Eq,Ord,Typeable)+data Disease = BSE | FM+ deriving (Show,Eq,Typeable)
+ examples/HListExample/Labelable.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds,+ GADTs, ConstraintKinds #-}+{- | Demonstrates @hLens'@++may be worthwhile to have a lens-free test suite, doing stuff like:++> case x (Identity . (++"there")) r of Identity t -> t++-}+module HListExample.Labelable where+import Data.HList.CommonMain+import Control.Lens++import Text.Read++import Properties.Common+import Test.Hspec+++makeLabelable "lbX lbY"++#if __GLASGOW_HASKELL__ < 707+#define INT_SIG_76 :: Int+#else+#define INT_SIG_76+#endif++r = lbX .==. "hi" .*.+ lbY .==. (lbY .==. 321 .*. lbX .==. 123 .*. emptyRecord) .*.+ emptyRecord++mainLabelable = describe "labelable" $ do+ it "lookup" $ do+ r ^. lbX `shouldShowTo` "\"hi\""++ -- ghc-7.6 doesn't default when r is involved lower down,+ -- while 7.8.2 does+ (r ^. lbY . lbY INT_SIG_76) `shouldShowTo` "321"+ (r ^. lbY . lbX INT_SIG_76) `shouldShowTo` "123"++ it "modify" $ do+ r & lbX .~ () `shouldShowTo`+ "Record{lbX=(),lbY=Record{lbY=321,lbX=123}}"++ r & lbY . lbY .~ "xy" `shouldShowTo`+ "Record{lbX=\"hi\",lbY=Record{lbY=\"xy\",lbX=123}}"++ it "read/show" $ do+ let rString = "Record{lbX=\"hi\",lbY=Record{lbY=321,lbX=123}}"++ r `shouldShowTo` rString++ readMaybe rString `asTypeOf` Just r+ `shouldBe` Just r++ -- the read instance does not reorder labels+ let rStringPerm = "Record{lbY=Record{lbY=321,lbX=123},lbX=\"hi\"}"+ readMaybe rStringPerm `asTypeOf` Just r+ `shouldBe` Nothing++ -- but we can reorder this way+ (r ^. rearranged) `asTypeOf` (undefined :: Record '[Tagged "lbY" t, Tagged "lbX" s])+ `shouldShowTo` rStringPerm
+ examples/HListExample/MainGhcGeneric1.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{-++ (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++ This is a main module for exercising a model with generic type+ cast and generic type equality.++-}++module HListExample.MainGhcGeneric1 (mainGhcGeneric1) where++import HListExample.Datatypes2+import Data.HList.CommonMain+import Control.Lens++import Properties.Common+import Test.Hspec++import Control.Monad.Writer++-- --------------------------------------------------------------------------++type Animal = '[Key,Name,Breed,Price]++angus :: HList Animal+angus = HCons (Key 42)+ (HCons (Name "Angus")+ (HCons Cow+ (HCons (Price 75.5)+ HNil)))++tlist1 = hFoldr (HSeq HPrint) (return () :: IO ()) angus++testBasic = do+ it "basic" $ do+ -- tlist1 does IO. The equivalent using Writer+ let f = HSeq $ HComp (tell . (:[])) HShow+ f2 = Fun (tell . (:[]) . show) :: Fun Show (Writer [String] ())++ angusStr = ["Key 42", "Name \"Angus\"", "Cow", "Price 75.5" ]++ execWriter (hFoldr f (return ()) angus) `shouldBe`+ angusStr++ execWriter (hFoldr (HSeq f2) (return ()) angus) `shouldBe`+ angusStr+++ hAppend angus angus `shouldShowTo` + "H[Key 42,Name \"Angus\",Cow,Price 75.5,Key 42,Name \"Angus\",Cow,Price 75.5]"+++testHArray = do+ it "HArray" $ do+ hProjectByHNats (hNats (HCons hZero (HCons hZero HNil))) angus `shouldShowTo`+ "H[Key 42]"++ -- Before:+ -- H[Key 42, Key 42]+ -- XXX I don't duplicate at present!+ hProjectByHNats (hNats (HCons hZero (HCons (hSucc hZero) HNil))) angus `shouldShowTo`+ "H[Key 42,Name \"Angus\"]"++ hProjectByHNats (undefined::Proxy ['HZero, 'HSucc 'HZero]) angus `shouldShowTo`+ "H[Key 42,Name \"Angus\"]"++ hProjectAwayByHNats (hNats (HCons hZero HNil)) angus `shouldShowTo`+ "H[Name \"Angus\",Cow,Price 75.5]"++ hSplitByHNats + (undefined::Proxy ['HZero, 'HSucc 'HZero])+ angus+ `shouldShowTo`+ "(H[Key 42,Name \"Angus\"],H[Cow,Price 75.5])"+++ it "HOccurs" $ do+ (hOccurs angus :: Breed) `shouldShowTo` "Cow"+ hOccurs angus `shouldBe` Cow++ hOccurs (hBuild 1 ^. from tipHList) `shouldShowTo` "1"++ (null $ hOccurs $ hBuild [] ^. from tipHList) `shouldBe` True+ (hProject angus :: HList '[Key, Name]) `shouldShowTo`+ "H[Key 42,Name \"Angus\"]"+++ it "TypeIndexed" $ do+ let typeIdx1 = hDeleteMany (undefined::Proxy Name) angus+ typeIdx2 = BSE .*. angus+ typeIdx1 `shouldShowTo` "H[Key 42,Cow,Price 75.5]"+ typeIdx2 `shouldShowTo` "H[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]"++ hUpdateAt Sheep typeIdx1 `shouldShowTo`+ "H[Key 42,Sheep,Price 75.5]"+ + hDeleteAt (undefined::Proxy Breed) typeIdx2 `shouldShowTo`+ "H[BSE,Key 42,Name \"Angus\",Price 75.5]"++ hProjectBy (undefined::Proxy '[Breed]) angus `shouldShowTo` "H[Cow]"++ hProject angus `shouldBe` HCons Cow HNil++ -- doesn't work+ -- hProjectBy Proxy angus `shouldBe` HCons Cow HNil++ hSplitBy (undefined:: Proxy '[Breed]) angus `shouldShowTo`+ "(H[Cow],H[Key 42,Name \"Angus\",Price 75.5])"++testTIP = do+ -- |+ -- This example from the TIR paper challenges singleton lists.+ -- Thanks to the HW 2004 reviewer who pointed out the value of this example.+ -- We note that the explicit type below is richer than the inferred type.+ -- This richer type was needed for making this operation more polymorphic.+ -- That is, /a)/ would not work without the explicit type, + -- while /b/ would:+ --+ -- > a) ((+) (1::Int)) $ snd $ tuple oneTrue+ -- > b) ((+) (1::Int)) $ fst $ tuple oneTrue+ --+ -- As of 2014, type signatures are not needed to define tipyTuple.+ it "tipyTuple" $ do+ let tuple l = tipyTuple l++ -- oneTrue :: TIP (TagR [Int, Bool]) -- inferred+ -- oneTrue :: TIP '[Tagged Int Int, Tagged Bool Bool] -- expanded out+ oneTrue = (1::Int) .*. True .*. emptyTIP++ case tuple oneTrue of+ (a,b) -> (a+(1::Int), not b) `shouldShowTo` "(2,False)"++ not (fst (tuple oneTrue)) `shouldShowTo` "False"+ tuple oneTrue `shouldBe` (1::Int,True)++ (((+) (1::Int)) $ fst $ tuple oneTrue) `shouldBe` 2+ (((+) (1::Int)) $ snd $ tuple oneTrue) `shouldBe` 2+++ it "tip" $ do+ hOccurs myTipyCow `shouldBe` Cow+ (BSE .*. myTipyCow) `shouldShowTo` "TIPH[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]"+ -- (Sheep .*. myTipyCow) `shouldBe` _+ {- if we uncomment the line above, we get the type error+ about the violation of the TIP condition: Breed type+ occurs twice.++ No instance for (Fail * (TypeFound Breed))+ -}++ (Sheep .*. hDeleteAtLabel (Label :: Label Breed) myTipyCow)+ `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]"++ (Sheep .*. (myTipyCow .-. (Label :: Label Breed)))+ `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]"++ tipyUpdate Sheep myTipyCow+ `shouldShowTo` "TIPH[Key 42,Name \"Angus\",Sheep,Price 75.5]"+++++myTipyCow = tipHList # angus -- lens #++animalKey :: ( SubType l (TIP Animal) -- explicit+ , HOccurs Key l -- implicit+ ) => l -> Key+animalKey = hOccurs++animalish :: SubType l (TIP Animal) => l -> l+animalish = id+animalKey' l = hOccurs (animalish l) :: Key+++makeLabels3 "MyNS" (words "key name breed price")+{- ^ makeLabels3 generates something like+data MyNS = MyNS -- a name space for record labels++key = firstLabel MyNS (undefined::DKey)+name = nextLabel key (undefined::DName)+breed = nextLabel name (undefined::DBreed)+price = nextLabel breed (undefined::DPrice)++data DKey; instance Show DKey where show _ = "key"+data DName; instance Show DName where show _ = "name"+data DBreed; instance Show DBreed where show _ = "breed"+data DPrice; instance Show DPrice where show _ = "price"++-}++unpricedAngus = key .=. (42::Integer)+ .*. name .=. "Angus"+ .*. breed .=. Cow+ .*. emptyRecord+++testRecords = describe "testRecords" $ it "tests" $ do++ unpricedAngus `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Cow}"+ unpricedAngus .!. breed `shouldShowTo` "Cow"++ let test3 = hDeleteAtLabel breed unpricedAngus++ test3+ `shouldShowTo` "Record{key=42,name=\"Angus\"}"++ (breed .=. Sheep .@. unpricedAngus)+ `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Sheep}"++ let test4 = price .=. 8.8 .*. unpricedAngus++ test4+ `shouldShowTo` "Record{price=8.8,key=42,name=\"Angus\",breed=Cow}"++ hProjectByLabels (labelsOf (breed `HCons` price `HCons` HNil)) test4+ `shouldShowTo` "Record{price=8.8,breed=Cow}"++ -- XXX extra Label shouldn't be needed?+ -- alternatively it could be a compile-time error...+ -- hProjectByLabels (hEndP $ hBuild breed price) test4+ -- `shouldShowTo` "Record{price=8.8,breed=Cow}"++ -- test7 should be the same as test4 but+ -- with the different order of labels+ (newLVPair breed Sheep) .*. test3+ `shouldShowTo` "Record{breed=Sheep,key=42,name=\"Angus\"}"+++type AnimalCol = TagR [Key,Name,Breed,Price]+++testTIC = describe "TIC" $ do+ it "show" $+ (myCol :: TIC AnimalCol) `shouldShowTo` "TIC{breed=Cow}"+ it "hOccurs found" $+ (hOccurs myCol :: Maybe Breed) `shouldBe` Just Cow+ it "hOccurs absent" $+ (hOccurs myCol :: Maybe Price) `shouldBe` Nothing++myCol = mkTIC Cow :: TIC AnimalCol+{-++*TIC> mkTIC "42" :: TIC AnimalCol+Type error ...++*TIC> hOccurs myCol :: Maybe String+Type error ...++-- both of the these type errors could be better+-- (on ghc-7.10.3), Any is used to satisfy FD coverage condition, but the+-- TypeError context should be printed instead+<interactive>:170:1:+ Couldn't match type ‘Data.HList.CommonMain.Any’ with ‘[Char]’+ In the expression: mkTIC "42" :: TIC AnimalCol+ In an equation for ‘it’: it = mkTIC "42" :: TIC AnimalCol+-}++testVariant = describe "Variant" $ it "test" $ do+ testVar1 `shouldShowTo` "V{name=\"angus\"}"+ (testVar1 .!. key) `shouldBe` Nothing+ (testVar1 .!. name) `shouldBe` Just "angus"+ where+ testVar1 = mkVariant name "angus" animalVar++animalVar = asProxy $+ key .=. (undefined :: Integer)+ .*. name .=. (undefined :: String)+ .*. breed .=. (undefined :: Breed)+ .*. emptyRecord+++asProxy :: proxy a -> Proxy a+asProxy _ = Proxy++mainGhcGeneric1 = describe "mainGhcGeneric1" $ do+ testBasic+ testHArray+ testTIP+ testRecords+ testTIC+ testVariant
+ examples/HListExample/MainPosting051106.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# LANGUAGE TypeOperators #-}+#endif+module HListExample.MainPosting051106 where++-- Needed for a reply to the Haskell mailing list++import Data.HList.CommonMain hiding (Comp(..))+import Properties.Common+import Test.Hspec++mainPosting051106 = describe "hComposeList (a -> H[a -> b,b -> c,c -> d] -> d)" $ do+ it "defined here" $+ comp "abc" `shouldShowTo` "8"++ it "defined in HList" $+ hComposeList test2 "abc" `shouldShowTo` "8"++test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil))+test2 = length .*. (+1) .*. (*2) .*. HNil++data Comp++{- simpler class. wouldn't work with test2. The original HFoldr won't work with+ - Apply anymore.+instance Apply Comp (x -> y,y -> z)+ where+ type ApplyR Comp (x -> y,y -> z) = x -> z+ apply _ (f,g) = g . f+ -}++-- `~` is (built-in) TypeCast mentioned below+instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz)+ => ApplyAB Comp xyz xz+ where+ applyAB _ (f,g) = g . f++-- Function composition based on type code works.++comp = hFoldr (undefined::Comp) (id::Int -> Int) test++-- Function composition based on normal polymorphism doesn't+-- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++{-++From Ralf.Lammel at microsoft.com Mon Nov 7 00:11:01 2005+From: Ralf.Lammel at microsoft.com (Ralf Lammel)+Date: Sun Nov 6 23:50:27 2005+Subject: [Haskell-cafe] Type classes and hFoldr from HList+Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com>++Hi Greg,++Since hfoldr is right-associative, I prefer to reorder your list of+functions as follows:++> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons+((*2)::(Int->Int)) HNil))++Note that I also annotated length with its specific type.+(If you really wanted to leave things more polymorphic, you would need+to engage in TypeCast.)++Providing a specific Apply instance for (.) is not necessary, strictly+necessary. We could try to exploit the normal function instance for+Apply.++Let me recall that one here for convenience:++>instance Apply (x -> y) x y+> where+> apply f x = f x++Let me also recall the hFoldr instances:++>class HList l => HFoldr f v l r | f v l -> r+> where+> hFoldr :: f -> v -> l -> r++>instance HFoldr f v HNil v+> where+> hFoldr _ v _ = v++>instance ( HFoldr f v l r+> , Apply f (e,r) r'+> )+> => HFoldr f v (HCons e l) r'+> where+> hFoldr f v (HCons e l) = apply f (e,hFoldr f v l)+++To fit in (.), we would flip and uncurry it.+So we could try:++comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++This wouldn't work.+The trouble is the required polymorphism of the first argument of+hFoldr.+The type of that argument as such is polymorphic.+However, this polymorphism does not survive type class parameterization.+You see this by looking at the HCons instance of HFoldr.+The different occurrences of "f" would need to be used at different+types.+This would only work if the type class parameter f were instantiated by+the polymorphic type of (uncurry (flip (.))). (And even then we may need+something like TypeCast.)++What you can do is define a dedicated *type code* for composition.++comp = hFoldr (undefined::Comp) (id::Int -> Int) test++data Comp++instance Apply Comp (x -> y,y -> z) (x -> z)+ where+ apply _ (f,g) = g . f+++Ralf+++> -----Original Message-----+> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe-+> bounces@haskell.org] On Behalf Of Greg Buchholz+> Sent: Sunday, November 06, 2005 7:01 PM+> To: haskell-cafe@haskell.org+> Subject: [Haskell-cafe] Type classes and hFoldr from HList+>+>+> I was playing around with the HList library from the paper...+>+> Strongly typed heterogeneous collections+> http://homepages.cwi.nl/~ralf/HList/+>+> ...and I thought I'd try to fold the composition function (.) through+a+> heterogeneous list of functions, using hFoldr...+>+> >{-# OPTIONS -fglasgow-exts #-}+> >{-# OPTIONS -fallow-undecidable-instances #-}+> >+> >import CommonMain+> >+> >main = print $ comp "abc"+> >+> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons+length+> HNil))+> >+> >comp = hFoldr (.) id test+> >+> >instance Apply (a -> b -> c -> d) (a, b) (c -> d)+> > where+> > apply f (a,b) = f a b+>+> ...but it fails with the following type error...+>+> ]Compiling Main ( compose.hs, interpreted )+> ]+> ]compose.hs:10:7:+> ] No instances for (Apply ((b -> c) -> (a -> b) -> a -> c)+> ] (Int -> Int, r)+> ] ([Char] -> a3),+> ] Apply ((b -> c) -> (a -> b) -> a -> c) (Int ->+Int,+> r1) r,+> ] Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] ->+> Int, a1 ->a1) r1)+> ] arising from use of `hFoldr' at compose.hs:10:7-12+> ] Probable fix:+> ] add an instance declaration for (Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ] (Int -> Int, r)+> ] ([Char] -> a3),+> ] Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ](Int -> Int, r1) r,+> ] Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ]([a2] -> Int, a1 -> a1) r1)+> ] In the definition of `comp': comp = hFoldr (.) id test+>+> ...Anyway, I couldn't quite tell whether I was using hFoldr+incorrectly,+> or if I needed to have more constraints placed on the construction of+> "test", or if needed some sort of type-level function that resolves...+>+> Apply ((b -> c) -> (a -> b) -> a -> c)+>+> ...into (a -> c), or something else altogether. I figured someone+might+> be able to help point me in the right direction.++-}
+ examples/HListExample/OverloadedLabels.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedLabels, TypeOperators, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes, PolyKinds, TypeApplications, DataKinds #-}+module HListExample.OverloadedLabels where++import Data.HList.CommonMain+import GHC.OverloadedLabels+import Control.Lens+import Data.HList.Labelable+import Properties.Common+import Test.Hspec+import GHC.TypeLits++{- | -XOverloadedLabels expands #foo into `hLens' (Label :: Label "foo")`+++Not in Data.HList.Labelable because it would overlap other uses of IsLabel+-}+instance (Labelable x r s t a b, x ~ x_,+ lens ~ ((a `p` f b) `to` (r s `p` f (r t))),+ ty ~ LabelableTy r,+ LabeledOpticF ty f,+ LabeledOpticP ty p,+ LabeledOpticTo ty x to + ) => IsLabel x_ lens where+ fromLabel = hLens' (Label :: Label x)+++{- | hLens' where the `x` type parameter must be supplied by -XTypeApplications.+In other words these are all equivalent:++> hLens' (Label :: Label "abc")+> hLens' (Label @"abc")+> hL @"abc"+> `abc -- HListPP+ +-}+hL :: forall x r s t a b to p f.+ Labelable x r s t a b =>+ LabeledOptic x r s t a b +hL = hLens' (Label :: Label x)+++r = #abc .==. 3 .*. emptyRecord+++mainOverloadedLabels = describe "-XOverloadedLabels" $ do+ it "lookup" $ do+ r ^. #abc `shouldShowTo` "3"+ r ^. hL @"abc" `shouldShowTo` "3"
+ examples/HListExample/Prism.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-} -- for pun+{-# LANGUAGE TemplateHaskell #-}+module HListExample.Prism where+++import Test.Hspec+import Properties.Common++import Data.HList.CommonMain+import Data.HList.Labelable (hLens')+import Control.Lens++-- generate left = Label :: Label "left"+makeLabels6 (words "left right up down")++--- define the Labelable labels manually+left_ = hLens' left+right_ = hLens' right+up_ = hLens' up+down_ = hLens' down++-- this definition is needed to decide what order+-- to put the fields in, as well as their initial types+r = [pun|right left up|] where+ left = 'a'+ right = 2 :: Int+ up = 2.3 :: Double++r2 = down_ .==. v .*. r++v = mkVariant left 'x' r++mainPrism = do+ it "inspect v with hPrism" $ do+ v ^? hPrism left `shouldShowTo` "Just 'x'"+ v ^? hPrism right `shouldBe` Nothing+ v ^? hPrism up `shouldBe` Nothing+ v2 ^? hPrism left `shouldShowTo` "Just ()"++ it "inspect v with hPrism through Labelable" $ do+ v ^? left_ `shouldShowTo` "Just 'x'"+ v ^? right_ `shouldBe` Nothing+ v ^? up_ `shouldBe` Nothing+ v2 ^? left_ `shouldShowTo` "Just ()"++ it "Setting the missing tag does nothing" $ do+ set right_ () v `shouldShowTo` "V{left='x'}"++ set _Right () (Left 'x') -- prisms for Either do the same thing+ `shouldShowTo` "Left 'x'"++ it "compose prism" $ do+ v3 ^? up_.up_ `shouldBe` Nothing+ v3 ^? left_ `shouldShowTo` "Just 'x'"++ v4 ^? left_.left_ `shouldShowTo` "Just \"leftleft\""++ it "compose lens.prism" $ do+ r2 ^? down_.left_ `shouldShowTo` "Just 'x'"+ r2 ^? down_.right_ `shouldBe` Nothing++ let du = down_.up_+ r2 ^? du `shouldBe` Nothing++ it "extension" $ do+ v5 ^? down_ `shouldBe` Just "hi"+ v6 ^? down_ `shouldBe` Just "hi"+ v7 ^? down_ `shouldBe` Nothing+ v7 ^? left_ `shouldBe` Just 'x'++ it "show" $ do+ vs `shouldShowTo`+ "Record{v=V{left='x'},\+ \v2=V{left=()},\+ \v2'=V{left=()},\+ \v3=V{left='x'},\+ \v4=V{left=V{left=\"leftleft\"}},\+ \v5=V{down=\"hi\"},\+ \v6=V{down=\"hi\"},\+ \v7=V{left='x'}}"++ -- works in ghci. Probably need -XExtendedDefaultRules+ -- wX `shouldShowTo` "V{x='a'}"+ -- wY `shouldShowTo` "V{y=2.5}"+ [wX,wY] `shouldShowTo` "[V{x='a'},V{y=2.5}]"++ -- :t wX+ -- > wX :: Variant '[Tagged "x" Char, Tagged "y" y]+ --+ -- > :t wY+ -- > wY :: Variant '[Tagged "x" x, Tagged "y" Double]+ --+ -- ghc doesn't need to decide on a type for values that+ -- have no influence on the final result+ it "type partly defined" $ do+ wX ^? hLens' (Label :: Label "x")+ `shouldShowTo` "Just 'a'"+ wY ^? hLens' (Label :: Label "y")+ `shouldShowTo` "Just 2.5"+ ++wX = mkVariant (Label :: Label "x") 'a' wProto+wY = mkVariant (Label :: Label "y") (2.5 :: Double) wProto++wProto = undefined :: Record+ '[Tagged "x" x, Tagged "y" y]++vs = [pun| v v2 v2' v3 v4 v5 v6 v7 |]++-- note that we can change the type of the 'x' field+-- from Char to ()+v2 = set (hPrism left) () v+++-- or with the "better" label+v2' = set left_ () v+++v3 = v & up_ .~ v & up_.up_ .~ "upup"+v4 = v & left_ .~ v & left_.left_ .~ "leftleft"+v5 = down .=. Just "hi" .*. v+v6 = down_ .==. Just "hi" .*. v+v7 = down .=. (Nothing :: Maybe String) .*. v
+ examples/HListExample/Pun.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+-- more examples for record puns+module HListExample.Pun where+import Data.HList.CommonMain++import Test.Hspec+import Properties.Common++makeLabels6 (words "a b c")+++r = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord+r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord+++p1 ( (.!. b) -> (b@((.!. a) -> a))) = (a,b)++p2 [pun| b @ {a} |] = (a, b)++-- same as p2, but gives a warning+-- p3 [pun| b @ a |] = (a, b)++p4 [pun| b{a} |] = a -- b is not bound++-- adds `x' and `y' into a field called r+e1 = let x = 1; y = "hi" in [pun| r @ { x y } |]++-- updates the `c' field+e2 = let c = 1; y = "hi" in [pun| r @ { c y } |]++-- same as e1, but doesn't use a pre-existing r+e3 = let x = 1; y = "hi" in [pun| r { x y } |]+++mainPun = describe "pun quasiquoter" $ do+ it "pattern" $ do+ p1 r `shouldShowTo` "(3,Record{a=3})"+ p2 r `shouldShowTo` "(3,Record{a=3})"+ p4 r `shouldBe` 3++ it "expression" $ do+ e1 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\",c=\"c\",b=Record{a=3}}}"+ e2 `shouldShowTo` "Record{r=Record{c=1,y=\"hi\",b=Record{a=3}}}"+ e3 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\"}}"+
+ examples/HListExample/TIPTransform.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}++-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- +-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.++module HListExample.TIPTransform where++import Data.HList.CommonMain+import Data.Typeable++import Properties.Common+import Test.Hspec++-- We start with the examples++newtype MyVal = MyVal Int deriving (Show, Typeable)++-- or if no typeable, use+-- instance ShowLabel MyVal where showLabel _ = "MyVal"++tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP+++mainTIPTransform = describe "tipTransform" $ it "all" $ do+ tip1 `shouldShowTo` "TIPH[MyVal 20,1,True]"++ -- Update the Int component of tip1 to 2. The Int component must+ -- exist. Otherwise, it is a type error+ ttip (2::Int) tip1 `shouldShowTo`+ "TIPH[MyVal 20,2,True]"++ -- Negate the boolean component of tip1+ ttip not tip1 `shouldShowTo`+ "TIPH[MyVal 20,1,False]"++ -- Update the Int component from the values of two other components+ ttip (\(MyVal x) y -> x+y) tip1 `shouldShowTo`+ "TIPH[MyVal 20,21,True]"++ -- Update the MyVal component from the values of three other components+ ttip (\b (MyVal x) y -> MyVal $ if b then x+y else 0) tip1+ `shouldShowTo`+ "TIPH[MyVal 21,1,True]"++ -- The same but with the permuted argument order.+ -- The order of arguments is immaterial: the values will be looked up using+ -- their types+ ttip (\b y (MyVal x)-> MyVal $ if b then x+y else 0) tip1+ `shouldShowTo`+ "TIPH[MyVal 21,1,True]"++-- The implementation+-- part of HList proper now
+ examples/HListExample/TIPTransformM.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-} -- !TF+-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- The monadic version.+-- This file contains two versions of the code.+-- The comments -- !Simple and -- !TF distinguish the versions+--+-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.+-- In March 2010, Andrew Frank extended the problem for monadic operations.+-- This is the monadic version of TIPTransform.hs in the present directory.+++module HListExample.TIPTransformM where++import Data.HList.CommonMain+import Data.Typeable+import Control.Monad.Identity+import Control.Monad.Writer++import Test.Hspec+import Properties.Common++-- We start with the examples++newtype MyVal = MyVal Int deriving (Show,Typeable)++-- A specialized version of return for the Identity monad.+-- It is needed only for the Simple version of the code,+-- to tell the type checker the monad in which the computation is+-- taking place.+-- For the TF version of the code, we can use the ordinary return+-- in place of retI.+retI :: a -> Identity a+retI = return++-- A sample TIP+tip1 = MyVal 20 .*. (1::Int) .*. True .*. (3.5::Float) .*. emptyTIP+-- TIP (HCons (MyVal 20) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Update the Int component of tip1 to 2. The Int component must+-- exist. Otherwise, it is a type error+-- tip2 = runIdentity $ ttipM (retI (2::Int)) tip1 -- !Simple+tip2 = runIdentity $ ttipM (return (2::Int)) tip1 -- !TF+-- TIP (HCons (MyVal 20) (HCons 2 (HCons True (HCons 3.5 HNil))))+++-- Negate the boolean component of tip1+-- tip3 = runIdentity $ ttipM (retI . not) tip1 -- !Simple+tip3 = runIdentity $ ttipM (return . not) tip1 -- !TF+-- TIP (HCons (MyVal 20) (HCons 1 (HCons False (HCons 3.5 HNil))))++-- Update the Int component from the values of two other components+tip4 = runIdentity $ ttipM (\(MyVal x) y -> retI $ x+y) tip1+-- TIP (HCons (MyVal 20) (HCons 21 (HCons True (HCons 3.5 HNil))))++-- Update the MyVal component from the values of three other components+tip5 = runIdentity $ + ttipM (\b (MyVal x) y -> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- The same but with the permuted argument order.+-- The order of arguments is immaterial: the values will be looked up using+-- their types+tip5' = runIdentity $ + ttipM (\b y (MyVal x)-> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Andrew Frank's test+-- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil)))))+tip6 :: IO (TIP (TagR [MyVal,Int,Bool, Float]))+tip6 = ttipM op6 tip1++op6 :: MyVal -> Bool -> IO MyVal+op6 (MyVal x) b = do+ let m = if b then MyVal (x `div` 4) else MyVal (x * 4)+ putStrLn $ "MyVal is now " ++ show m+ -- ==>> MyVal 5+ return m+-- TIP (HCons (MyVal 5) (HCons 1 (HCons True (HCons 3.5 HNil))))+++op6w :: MyVal -> Bool -> Writer String MyVal+op6w (MyVal x) b = do+ let m = if b then MyVal (x `div` 4) else MyVal (x * 4)+ tell ("MyVal is now " ++ show m)+ -- ==>> MyVal 5+ return m+++{- -- !Simple+-- The Simple implementation+-- The drawback is the need to let the type checker know the monad in which the+-- computations take place. That is why we had to use retI in the above+-- code, which is a specialized version of return for the Identity monad. +-- In op6, the presence of putStrLn unambiguously specified the monad, viz. IO,+-- so no special return are required.++class Monad m => TransTIPM m op db where+ ttipM :: op -> db -> m db++-- If the operation is the computation in the desired monad,+-- the type of the computation must match an element of TIP.+instance (Monad m,+ HTypeIndexed db, HUpdateAtHNat n op db db, HType2HNat op db n)+ => TransTIPM m (m op) (TIP db) where+ ttipM op db = do+ op' <- op+ return $ tipyUpdate op' db++-- If op is not a computation in the desired monad m, +-- it must be a function. Look up its argument in a TIP and recur.+instance (Monad m, HOccurs arg db, TransTIPM m op db)+ => TransTIPM m (arg -> op) db where+ ttipM f db = ttipM (f (hOccurs db)) db+-} -- !Simple++-- {- -- !TF+-- Moved to TIP.hs+-- -} -- !TF++mainTTIPM = describe "ttipM" $ it "all" $ do+ tip1 `shouldShowTo` "TIPH[MyVal 20,1,True,3.5]"+ tip2 `shouldShowTo` "TIPH[MyVal 20,2,True,3.5]"+ tip3 `shouldShowTo` "TIPH[MyVal 20,1,False,3.5]"+ tip4 `shouldShowTo` "TIPH[MyVal 20,21,True,3.5]"+ tip5 `shouldShowTo` "TIPH[MyVal 21,1,True,3.5]"+ let tip6w = runWriter (ttipM op6w tip1)+ fst tip6w `shouldShowTo` "TIPH[MyVal 5,1,True,3.5]"+ snd tip6w `shouldBe` "MyVal is now MyVal 5"+
− examples/MainGhcGeneric1.hs
@@ -1,318 +0,0 @@-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--{--- (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke-- This is a main module for exercising a model with generic type- cast and generic type equality. Because of generic type equality,- this model works with GHC but it does not work with Hugs.---}--module MainGhcGeneric1 where--import Datatypes2-import Data.HList.CommonMain-import Control.Lens--asProxy :: proxy a -> Proxy a-asProxy _ = Proxy----- ----------------------------------------------------------------------------type Animal = '[Key,Name,Breed,Price]--angus :: HList Animal-angus = HCons (Key 42)- (HCons (Name "Angus")- (HCons Cow- (HCons (Price 75.5)- HNil)))--tList1 = hFoldr (HSeq HPrint) (return () :: IO ()) angus-{-- Key 42- Name "Angus"- Cow- Price 75.5--}--tList2 = print $ hAppend angus angus-{--H[Key 42, Name "Angus", Cow, Price 75.5, Key 42, Name "Angus", Cow, Price 75.5]--}---testListBasic = do- putStrLn "\nBasic HList tests"- tList1- tList2--testHArray = do- putStrLn "\ntestHArray"- myProj1- myProj2- myProj2'- myProj3- myProj4--myProj1 = print $ hProjectByHNats (hNats (HCons hZero (HCons hZero HNil))) angus--- H[Key 42]---- Before:--- H[Key 42, Key 42]--- XXX I don't duplicate at present!--myProj2 = print $ - hProjectByHNats (hNats (HCons hZero (HCons (hSucc hZero) HNil))) angus--- H[Key 42, Name "Angus"]--myProj2' = print $ - hProjectByHNats (undefined::Proxy ['HZero, 'HSucc 'HZero]) angus--- H[Key 42, Name "Angus"]--myProj3 = print $ - hProjectAwayByHNats (hNats (HCons hZero HNil)) angus--- H[Name "Angus", Cow, Price 75.5]--myProj4 = print $ - hSplitByHNats - (undefined::Proxy ['HZero, 'HSucc 'HZero])- angus--- (H[Key 42, Name "Angus"],H[Cow, Price 75.5])---testHOccurs = do- putStrLn "\ntestHOccurs"- print (hOccurs angus :: Breed)- print $ hOccurs $ hBuild 1 ^. from tipHList- print $ null $ hOccurs $ hBuild [] ^. from tipHList- print (hProject angus :: HList '[Key, Name])---testTypeIndexed = do- putStrLn "\ntestTypeIndexed"- print typeIdx1- print typeIdx2- print $ hUpdateAt Sheep typeIdx1- print $ hDeleteAt (undefined::Proxy Breed) typeIdx2- print $ hProjectBy (undefined::Proxy '[Breed]) angus- print $ hSplitBy (undefined:: Proxy '[Breed]) angus- where - typeIdx1 = hDeleteMany (undefined::Proxy Name) angus- typeIdx2 = BSE .*. angus---- |--- This example from the TIR paper challenges singleton lists.--- Thanks to the HW 2004 reviewer who pointed out the value of this example.--- We note that the explicit type below is richer than the inferred type.--- This richer type was needed for making this operation more polymorphic.--- That is, /a)/ would not work without the explicit type, --- while /b/ would:------ > a) ((+) (1::Int)) $ snd $ tuple oneTrue--- > b) ((+) (1::Int)) $ fst $ tuple oneTrue------ Currently (2014) type signatures are not needed to define tipyTuple.--tuple l = tipyTuple l----- | A specific tuple--- Need to import an instance of TypeEq to be able to run the examples--- oneTrue :: TIP (TagR [Int, Bool]) -- inferred-oneTrue = (1::Int) .*. True .*. emptyTIP--testTuple = do- putStrLn "\ntestTuple"- print $ let (a,b) = tuple oneTrue in (a+(1::Int), not b)- print $ let b = not $ fst $ tuple oneTrue in (1::Int,b)- print $ tuple oneTrue == (1::Int,True)- print $ ((+) (1::Int)) $ fst $ tuple oneTrue- print $ ((+) (1::Int)) $ snd $ tuple oneTrue---myTipyCow = angus ^. from tipHList--animalKey :: ( SubType l (TIP Animal) -- explicit- , HOccurs Key l -- implicit- ) => l -> Key-animalKey = hOccurs--animalish :: SubType l (TIP Animal) => l -> l-animalish = id-animalKey' l = hOccurs (animalish l) :: Key--testTIP = do- putStrLn "\ntestTIP"- print $ (hOccurs myTipyCow :: Breed)- print $ BSE .*. myTipyCow- -- print $ Sheep .*. myTipyCow- {- if we uncomment the line above, we get the type error- about the violation of the TIP condition: Breed type- occurs twice.-- No instance for (Fail * (TypeFound Breed))- arising from a use of `hExtend'- -}- print $ Sheep .*. hDeleteAtLabel (Label::Label Breed) myTipyCow- print $ tipyUpdate Sheep myTipyCow--{--data MyNS = MyNS -- a name space for record labels--key = firstLabel MyNS (undefined::DKey)-name = nextLabel key (undefined::DName)-breed = nextLabel name (undefined::DBreed)-price = nextLabel breed (undefined::DPrice)--data DKey; instance Show DKey where show _ = "key"-data DName; instance Show DName where show _ = "name"-data DBreed; instance Show DBreed where show _ = "breed"-data DPrice; instance Show DPrice where show _ = "price"---}--makeLabels3 "MyNS" (words "key name breed price")--unpricedAngus = key .=. (42::Integer)- .*. name .=. "Angus"- .*. breed .=. Cow- .*. emptyRecord---getKey l = hLookupByLabel key l--testRecords = do- putStrLn "\ntestRecords"- print $ unpricedAngus- print $ unpricedAngus .!. breed- print $ test3- print $ test4- print $ test5- print $ hProjectByLabels (labelsOf (breed `HCons` price `HCons` HNil)) test5- where- test3 = hDeleteAtLabel breed unpricedAngus- test4 = breed .=. Sheep .@. unpricedAngus- test5 = price .=. 8.8 .*. unpricedAngus- -- test7 should have the same type as unpricedAngus and test4 but- -- with the different order of labels- test7 = (newLVPair breed Sheep) .*. test3--{--testRecords = ( test1 - , ( test2- , ( test3 - , ( test4- , ( test5- , ( test6- , (test7, test81, test82, test83, test84, test85)- ))))))- where- test81 = equivR test1 test3 -- HNothing- test82 = let HJust (r17,r71) = equivR test1 test7 in (r17 test1,r71 test7)- test83 = let HJust (r17,r71) = - equivR test1 test7 in show (r17 test1) == show test7- test84 = let HJust (r47,r74) = - equivR test4 test7 in (show (r47 test4) == show test7,- show (r74 test7) == show test4)- test85 = let HJust (r7,r7') = - equivR test7 test7 in show (r7 test7) == show (r7' test7)--testRecordsP = ( test1 - , ( test2- , ( test3 - , ( test4- , ( test5- , ( test6- ))))))- where--- test1 = mkRecordP (undefined::Animal) angus- test1 = record_r2p unpricedAngus- test2 = test1 .!. breed- test3 = hDeleteAtLabelP breed test1--- test4 = test1 .@. breed .=. Sheep- test4 = hExtend (newLVPair breed Sheep) test3- test5 = price .=. 8.8 .*. test1- test6 = fst $ h2projectByLabels (HCons breed (HCons price HNil)) test5----}---type AnimalCol = TagR [Key,Name,Breed,Price]--testTIC = do- putStrLn "\ntestTIC"- print $ myCol- print $ (hOccurs myCol :: Maybe Breed)- print $ (hOccurs myCol :: Maybe Price)- where- myCol = mkTIC Cow :: TIC AnimalCol--{---myCol = mkTIC Cow :: TIC AnimalCol--*TIC> hOccurs myCol :: Maybe Breed-Just Cow-*TIC> hOccurs myCol :: Maybe Price-Nothing-*TIC> mkTIC "42" :: TIC AnimalCol-Type error ...-*TIC> hOccurs myCol :: Maybe String-Type error ...---}--testVariant = do- putStrLn "\ntestVariant"- print testVar1- print testVar2- print testVar3- where- testVar1 = mkVariant name "angus" animalVar- testVar2 = testVar1 .!. key- testVar3 = testVar1 .!. name--animalVar = asProxy $- key .=. (undefined :: Integer)- .*. name .=. (undefined :: String)- .*. breed .=. (undefined :: Breed)- .*. emptyRecord-{---- ----------------------------------------------------------------------------main = mainExport-mainExport- = print $ ( testHArray- , ( testHOccurs- , ( testTypeIndexed- , ( testTuple- , ( testTIP-- , ( testRecords- , ( testRecordsP- , ( testTIC- , ( testVariant- )))))))))---}--main = do- testListBasic- testHArray- testHOccurs- testTypeIndexed- testTuple- testTIP- testRecords- testTIC- testVariant
− examples/MainGhcGeneric1.ref
@@ -1,59 +0,0 @@--Basic HList tests-Key 42-Name "Angus"-Cow-Price 75.5-H[Key 42,Name "Angus",Cow,Price 75.5,Key 42,Name "Angus",Cow,Price 75.5]--testHArray-H[Key 42]-H[Key 42,Name "Angus"]-H[Key 42,Name "Angus"]-H[Name "Angus",Cow,Price 75.5]-(H[Key 42,Name "Angus"],H[Cow,Price 75.5])--testHOccurs-Cow-1-True-H[Key 42,Name "Angus"]--testTypeIndexed-H[Key 42,Cow,Price 75.5]-H[BSE,Key 42,Name "Angus",Cow,Price 75.5]-H[Key 42,Sheep,Price 75.5]-H[BSE,Key 42,Name "Angus",Price 75.5]-H[Cow]-(H[Cow],H[Key 42,Name "Angus",Price 75.5])--testTuple-(2,False)-(1,False)-True-2-2--testTIP-Cow-TIPH[BSE,Key 42,Name "Angus",Cow,Price 75.5]-TIPH[Sheep,Key 42,Name "Angus",Price 75.5]-TIPH[Key 42,Name "Angus",Sheep,Price 75.5]--testRecords-Record{key=42,name="Angus",breed=Cow}-Cow-Record{key=42,name="Angus"}-Record{key=42,name="Angus",breed=Sheep}-Record{price=8.8,key=42,name="Angus",breed=Cow}-Record{price=8.8,breed=Cow}--testTIC-TIC{breed=Cow}-Just Cow-Nothing--testVariant-V{name="angus"}-Nothing-Just "angus"
− examples/MainGhcGeneric2.hs
@@ -1,22 +0,0 @@-{--- (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke-- Included for completeness' sake.- The TypeEqBoolGeneric2.hs implementation is demonstrated.---}--module MainGhcGeneric2 where--import Data.HList---{-----------------------------------------------------------------------------}--main = print ( hEq True False- , hEq True "True"- )---{-----------------------------------------------------------------------------}
− examples/MainGhcGeneric2.ref
@@ -1,1 +0,0 @@-(HTrue,HFalse)
− examples/MainPatternMatch.hs
@@ -1,80 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE PatternGuards #-}---- Pattern-matching on HList's Records--{-- See the thread `Re: (small) records proposal for Haskell '06'- Haskell mailing list, January 2006- http://www.haskell.org/pipermail/haskell/2006-January/017276.html--Joel Reymont wrote:-> How does pattern matching work with HList?-> I would like to pass a HList to a function and only match if a-> certain field had a certain value.--The code below defines the function foo that accepts a record and-yields one value if the field PtX of the record has the value 0. If-the field has any other value, a different result is returned. The-function is written in a pattern-matching style. Also, the function is-record-polymorphic: it takes _any_ record (of any `record type') that-happens to have the field names PtX.-- *Test> :t foo- foo :: (Num v, HasField (Proxy PtX) r v) => r -> [Char]---}--module Main where--import Data.HList.CommonMain--makeLabels ["px","py"]---- Labels--- The more convenient labels, Label4.hs, need -fallow-overlapping-instances--- The less convenient label representation needs fewer extensions.--- We go for more convenient...--{--data PtX; px = proxy::Proxy PtX-data PtY; py = proxy::Proxy PtY--}---accessor r f = r .!. f---- 1D points-point1 x = - px .=. x- .*. emptyRecord---- 2D points-point2 x y = - px .=. x- .*. py .=. (y + 10)- .*. emptyRecord----- Record-polymorphic function, which illustrates record pattern-matching,--- with the help of generalized guards-foo p | 0 <- p .!. px = "X is zero"-foo _ = "something else"--test1 = foo (point1 0) -- X is zero-test1' = foo (point1 42) -- something else-test2 = foo (point2 10 20) -- something else--- inline construction of the record-test3 = foo (py .=. False .*. px .=. 0 .*. emptyRecord) -- X is zero--main = do- putStrLn test1- putStrLn test1'- putStrLn test2- putStrLn test3
− examples/MainPatternMatch.ref
@@ -1,4 +0,0 @@-X is zero-something else-something else-X is zero
− examples/MainPosting-040607.hs
@@ -1,304 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}--{---Hi Mike,--You might find heterogeneous lists useful.-http://www.cwi.nl/~ralf/HList/-See the treatment of your example below.--Cheers,-Ralf---}--module Main where--import Data.HList.CommonMain-import Data.Typeable---- These are your two "implementations".--data MyImplementation1 = MyImplementation1 Int deriving (Show,Eq,Typeable)-data MyImplementation2 = MyImplementation2 Int deriving (Show,Eq,Typeable)----- This is your interface class and the two instances.--class MyInterface a - where- foo :: a -> Int--instance MyInterface MyImplementation1- where- foo (MyImplementation1 i) = i--instance MyInterface MyImplementation2- where- foo (MyImplementation2 i) = i----- Here is your list,--- without the noise you don't like.--list1 = MyImplementation1 10- .*. MyImplementation2 20- .*. HNil----- If you like, this is the type, but it is not needed.--- This list is not opaque. Less trouble in our experience.--- (When compared to using existentials.)--type MyList = HList '[MyImplementation1, MyImplementation2]----- Perhaps you want to make sure that you have a list of implementations--- of MyInterface. Here is *one* way to do it. But you don't need to do it--- because this will be automatically checked (statically) whenever you--- try to use the fooISH interface.--class ListOfMyInterface l- where- listOfMyInterface :: HList l -> HList l- listOfMyInterface = id--instance ListOfMyInterface '[]-instance ( MyInterface e- , ListOfMyInterface l- )- => ListOfMyInterface (e ': l)----- So you apply the id function with the side effect of statically --- ensuring that you are given a list of implementations of MyInterface.--list2 :: MyList-list2 = listOfMyInterface list1----- Here is another way to do it.--- You apply a heterogenous fold to the list.--- This second solution is just for fun.--data ImplementsMyInterface = ImplementsMyInterface--instance (- x ~ (e,HList l),- y ~ (HList (e ': l))- ) => ApplyAB ImplementsMyInterface x y- where- applyAB _ (e,l) = HCons e l--myKindOfList l = hFoldr ImplementsMyInterface HNil l----- Basically again you apply the identity function; a deep one this time.--list3 :: MyList-list3 = myKindOfList list1----- Your equality can indeed not work because the existentially quantified--- implementations are of course opaque. You cannot compare apples and--- oranges. Equality of heterogeneous lists is trivial; it is just derived.--- To make it a little bit more interesting, we can consider heterogeneous--- or stanamic equality. So you will always get a Boolean even for lists--- of different types. See below.----- Here is your bar function.--- It uses one sort of maps on heterogeneous lists.--bar :: MyList -> Int-bar = sum . hMapOut Foo--data Foo = Foo -- type driver for class-level application--instance (MyInterface e, int ~ Int) => ApplyAB Foo e int- where- applyAB _ e = foo e----- Yet another heterogeneous equality.--- Just for fun.----yaHEq :: (Typeable a, Typeable b, Eq a) => a -> b -> Bool-yaHEq a b = case cast b of- Just a' -> a == a'- Nothing -> False---- Yet another heterogeneous list; a bit less typed.-data AnyMyInterface = forall a. ( Eq a- , Typeable a- , MyInterface a- ) => AnyMyInterface a--type MyList' = [AnyMyInterface]-list4 = [ AnyMyInterface $ MyImplementation1 10- , AnyMyInterface $ MyImplementation1 10- ]-list5 = [ AnyMyInterface $ MyImplementation1 10- , AnyMyInterface $ MyImplementation2 10- ]-list6 = [ AnyMyInterface $ MyImplementation1 10- , AnyMyInterface $ MyImplementation2 20- ]--instance Eq AnyMyInterface- where- (AnyMyInterface x) == (AnyMyInterface y) = x `yaHEq` y---{---Demo follows.--*Main> :l gh-users-040607.hs-Compiling FakePrelude ( ./FakePrelude.hs, interpreted )-Compiling HType ( HType.hs, interpreted )-Compiling HList ( ./HList.hs, interpreted )-Compiling HArray ( ./HArray.hs, interpreted )-Compiling HTypeDriven ( ./HTypeDriven.hs, interpreted )-Compiling Main ( gh-users-040607.hs, interpreted )-Ok, modules loaded: Main, HTypeDriven, HArray, HList, HType, FakePrelude.-*Main> list1-HCons (MyImplementation1 10) (HCons (MyImplementation2 20) HNil)-*Main> bar list1-30-*Main> list1 == list1-True-*Main> list1 `hStagedEq` hReverse list1-False-*Main> list4!!0 == list4!!1-True-*Main> list5!!0 == list5!!1-False-*Main> list6!!0 == list6!!1-False---}--main = print- ( list1- , ( list1 == list1- -- , ( list1 `hStagedEq` hReverse list1- , ( list4!!0 == list4!!1- , ( list5!!0 == list5!!1- , ( list6!!0 == list6!!1- )))))--{---Mike Aizatsky wrote:-->Hello,->->I'm in process of rewriting the old Java application. While this is for sure->lots of fun, there're some problems in modeling the java interfaces.->->Here's the common Java scenario (it's actually the pattern, common for all->OO-languages, so there should be no problems in understanding it):->->interface MyInterface {-> int foo();->}->->class MyImplementation1 implements MyInterface { int foo() {...} }->class MyImplementation2 implements MyInterface { int foo() {...} }->->And, somewhere in the code:->->int bar(List<MyInterface> list) { .... sum up all foos & return .... }->->I've found quite an obvious translation of it to Haskell:->->module Ex where->->class MyInterface a where-> foo :: a -> Int->->data AnyMyInterface = forall a. (MyInterface a) => AnyMyInterface a->->instance MyInterface AnyMyInterface where-> foo (AnyMyInterface a) = foo a->->->data MyImplementation1 = MyImplementation1 Int->->instance MyInterface MyImplementation1 where-> foo(MyImplementation1 i) = i->->data MyImplementation2 = MyImplementation2 Int->->instance MyInterface MyImplementation2 where-> foo(MyImplementation2 i) = i->->->type MyList = [AnyMyInterface]->->list1 :: MyList->list1 = [AnyMyInterface (MyImplementation1 10), AnyMyInterface->(MyImplementation2 20)]->->bar :: MyList -> Int->bar l = sum (map foo l)->->->However there're some problems with this way to go:->->1. It's quite verbose. I already have a dozen of such interfaces, and I'm a->bit tired of writing all this AnyInterface stuff. I'm already thinking about->writing the Template Haskell code to generate it. Is anything similar->available around?->->2. I don't like the fact that I need to wrap all implementations inside the->AnyMyInterface when returning values (see list1). Any way to get rid of it?->->3. The big problem. I can't make AnyMyInterface to be an instance of Eq. I->write:->->data AnyMyInterface = forall a. (MyInterface a, Eq a) => AnyMyInterface a->instance Eq AnyMyInterface where-> (==) (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2->->And it gives me an error (ghc 6.2.1):->-> Inferred type is less polymorphic than expected-> Quantified type variable `a1' is unified with another quantified->type variable `a'-> When checking an existential match that binds-> a1 :: a-> a2 :: a1-> The pattern(s) have type(s): AnyMyInterface-> AnyMyInterface-> The body has type: Bool-> In the definition of `==':-> == (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2-> In the definition for method `=='->->Honestly, I don't understand what's going on. My guess is that the problem->comes from the fact that a1 & a2 might be of different Implementations. Is->it right? Any way to define the Eq instance of AnyMyInterface?->->->So, it looks like that existential data types do allow you to mimic the->polymorphic data structures, found in OO languages. But it results in much->more verbose code. Are there any other ways to do the same stuff?->->_______________________________________________->Glasgow-haskell-users mailing list->Glasgow-haskell-users@haskell.org->http://www.haskell.org/mailman/listinfo/glasgow-haskell-users->---}
− examples/MainPosting-040607.ref
@@ -1,1 +0,0 @@-(H[MyImplementation1 10,MyImplementation2 20],(True,(True,(False,False))))
− examples/MainPosting-051106.hs
@@ -1,197 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Main where---- Needed for a reply to the Haskell mailing list--import Data.HList.CommonMain hiding (Comp(..))--main = do- print $ comp "abc"- print $ (hComposeList test2 "abc" :: Int) -- definition in HList now--test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil))-test2 = length .*. (+1) .*. (*2) .*. HNil--data Comp--{- simpler class. wouldn't work with test2. The original HFoldr won't work with- - Apply anymore.-instance Apply Comp (x -> y,y -> z)- where- type ApplyR Comp (x -> y,y -> z) = x -> z- apply _ (f,g) = g . f- -}--instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz)- => ApplyAB Comp xyz xz- where- applyAB _ (f,g) = g . f---- Function composition based on type code works.--comp = hFoldr (undefined::Comp) (id::Int -> Int) test---- Function composition based on normal polymorphism doesn't--- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test--{---From Ralf.Lammel at microsoft.com Mon Nov 7 00:11:01 2005-From: Ralf.Lammel at microsoft.com (Ralf Lammel)-Date: Sun Nov 6 23:50:27 2005-Subject: [Haskell-cafe] Type classes and hFoldr from HList-Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com>--Hi Greg,--Since hfoldr is right-associative, I prefer to reorder your list of-functions as follows:--> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons-((*2)::(Int->Int)) HNil))--Note that I also annotated length with its specific type.-(If you really wanted to leave things more polymorphic, you would need-to engage in TypeCast.)--Providing a specific Apply instance for (.) is not necessary, strictly-necessary. We could try to exploit the normal function instance for-Apply.--Let me recall that one here for convenience:-->instance Apply (x -> y) x y-> where-> apply f x = f x--Let me also recall the hFoldr instances:-->class HList l => HFoldr f v l r | f v l -> r-> where-> hFoldr :: f -> v -> l -> r-->instance HFoldr f v HNil v-> where-> hFoldr _ v _ = v-->instance ( HFoldr f v l r-> , Apply f (e,r) r'-> )-> => HFoldr f v (HCons e l) r'-> where-> hFoldr f v (HCons e l) = apply f (e,hFoldr f v l)---To fit in (.), we would flip and uncurry it.-So we could try:--comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test--This wouldn't work.-The trouble is the required polymorphism of the first argument of-hFoldr.-The type of that argument as such is polymorphic.-However, this polymorphism does not survive type class parameterization.-You see this by looking at the HCons instance of HFoldr.-The different occurrences of "f" would need to be used at different-types.-This would only work if the type class parameter f were instantiated by-the polymorphic type of (uncurry (flip (.))). (And even then we may need-something like TypeCast.)--What you can do is define a dedicated *type code* for composition.--comp = hFoldr (undefined::Comp) (id::Int -> Int) test--data Comp--instance Apply Comp (x -> y,y -> z) (x -> z)- where- apply _ (f,g) = g . f---Ralf---> -----Original Message------> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe--> bounces@haskell.org] On Behalf Of Greg Buchholz-> Sent: Sunday, November 06, 2005 7:01 PM-> To: haskell-cafe@haskell.org-> Subject: [Haskell-cafe] Type classes and hFoldr from HList-> -> -> I was playing around with the HList library from the paper...-> -> Strongly typed heterogeneous collections-> http://homepages.cwi.nl/~ralf/HList/-> -> ...and I thought I'd try to fold the composition function (.) through-a-> heterogeneous list of functions, using hFoldr...-> -> >{-# OPTIONS -fglasgow-exts #-}-> >{-# OPTIONS -fallow-undecidable-instances #-}-> >-> >import CommonMain-> >-> >main = print $ comp "abc"-> >-> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons-length-> HNil))-> >-> >comp = hFoldr (.) id test-> >-> >instance Apply (a -> b -> c -> d) (a, b) (c -> d)-> > where-> > apply f (a,b) = f a b-> -> ...but it fails with the following type error...-> -> ]Compiling Main ( compose.hs, interpreted )-> ]-> ]compose.hs:10:7:-> ] No instances for (Apply ((b -> c) -> (a -> b) -> a -> c)-> ] (Int -> Int, r)-> ] ([Char] -> a3),-> ] Apply ((b -> c) -> (a -> b) -> a -> c) (Int ->-Int,-> r1) r,-> ] Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] ->-> Int, a1 ->a1) r1)-> ] arising from use of `hFoldr' at compose.hs:10:7-12-> ] Probable fix:-> ] add an instance declaration for (Apply ((b -> c) -> (a -> b) ->-a --> > c)-> ] (Int -> Int, r)-> ] ([Char] -> a3),-> ] Apply ((b -> c) -> (a -> b) ->-a --> > c)-> ](Int -> Int, r1) r,-> ] Apply ((b -> c) -> (a -> b) ->-a --> > c)-> ]([a2] -> Int, a1 -> a1) r1)-> ] In the definition of `comp': comp = hFoldr (.) id test-> -> ...Anyway, I couldn't quite tell whether I was using hFoldr-incorrectly,-> or if I needed to have more constraints placed on the construction of-> "test", or if needed some sort of type-level function that resolves...-> -> Apply ((b -> c) -> (a -> b) -> a -> c)-> -> ...into (a -> c), or something else altogether. I figured someone-might-> be able to help point me in the right direction.---}
− examples/MainPosting-051106.ref
@@ -1,2 +0,0 @@-8 -8
examples/Properties.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# OPTIONS_GHC -freduction-depth=100 #-}+#else {-# OPTIONS_GHC -fcontext-stack=100 #-}+#endif {-# OPTIONS_GHC -fno-warn-deprecations #-} -- ghc-7.8 has no Typeable (x :: Symbol), so use OldTypeable {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-}@@ -33,11 +37,3 @@ hl0 hl1_2_3 kwSpecs--------
examples/Properties/Common.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-}@@ -10,6 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-} module Properties.Common where import Data.HList.CommonMain@@ -17,11 +19,20 @@ import Data.Array.Unboxed import Data.HList.Variant import Data.Monoid+import Data.Semigroup import Control.Lens import Control.Applicative import GHC.TypeLits (Symbol) import Language.Haskell.TH +#if MIN_VERSION_hspec_expectations(0,8,0)+import Test.Hspec.Expectations (shouldBe, shouldReturn, Expectation, HasCallStack)+#else+import Test.Hspec.Expectations (shouldBe, shouldReturn, Expectation)+import GHC.Exts (Constraint)+type HasCallStack = (() :: Constraint)+#endif+ hListT :: [TypeQ] -> TypeQ hListT = foldr (\a b -> [t| $a ': $b |]) promotedNilT @@ -51,6 +62,15 @@ eq x y = hCast x === Just y .&&. Just x === hCast y infix 4 `eq` ++shouldShowTo :: (HasCallStack, Show a) => a -> String -> Expectation+shouldShowTo x y = show x `shouldBe` y+infixr 0 `shouldShowTo`++shouldReturnShowTo :: (HasCallStack, Show a) => IO a -> String -> Expectation+shouldReturnShowTo x y = fmap show x `shouldReturn` y+infixr 0 `shouldReturnShowTo`+ data HSuccF = HSuccF instance (psn ~ Proxy (HSucc n),@@ -125,10 +145,20 @@ instance Monoid (BoolN n) where mempty = BoolN (getAll mempty)+#if __GLASGOW_HASKELL__ <= 906 mappend (BoolN x) (BoolN y) = BoolN (getAll (mappend (All x) (All y))) +instance Semigroup (BoolN n) where (<>) = mappend+#else++instance Semigroup (BoolN n) where+ (BoolN x) <> (BoolN y) = BoolN (getAll (mappend (All x) (All y)))+#endif++#if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary (Identity (BoolN n)) where arbitrary = fmap return arbitrary+#endif data HSortF = HSortF
examples/Properties/KW.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-} module Properties.KW where @@ -17,6 +18,62 @@ kwSpecs = describe "kw" $ do+ {- with NoMonoLocalBinds+ - /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:59:15: error:ghc: panic! (the 'impossible' happened)+ (GHC version 8.0.2 for x86_64-unknown-linux):+ No skolem info: k_aqoh[sk]++ with MonoLocalBinds, I think the error is the same as in earlier versions++ /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:62:15: error:+ • Couldn't match type ‘'[Tagged "x" (BoolN "x")]’ with ‘'[]’+ Expected type: Record '[]+ Actual type: HExtendR (Tagged "x" (BoolN "x")) (Record '[])+ • In the first argument of ‘f2’, namely+ ‘(lx .=. x2 .*. emptyRecord)’+ In the first argument of ‘eq’, namely+ ‘f2 (lx .=. x2 .*. emptyRecord)’+ In the expression: f2 (lx .=. x2 .*. emptyRecord) `eq` f1 x2 y+ + /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:63:15: error:+ • Couldn't match type ‘'[Tagged "y" (BoolN "y")]’ with ‘'[]’+ Expected type: Record '[]+ Actual type: HExtendR (Tagged "y" (BoolN "y")) (Record '[])+ • In the first argument of ‘f2’, namely+ ‘(ly .=. y2 .*. emptyRecord)’+ In the first argument of ‘eq’, namely+ ‘f2 (ly .=. y2 .*. emptyRecord)’+ In the expression: f2 (ly .=. y2 .*. emptyRecord) `eq` f1 x y2+ + /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:64:15: error:+ • Couldn't match type ‘'[Tagged "x" (BoolN "x"),+ Tagged "y" (BoolN "y")]’+ with ‘'[]’+ Expected type: Record '[]+ Actual type: HExtendR+ (Tagged "x" (BoolN "x")) (Record '[Tagged "y" (BoolN "y")])+ • In the first argument of ‘f2’, namely+ ‘(lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’+ In the first argument of ‘eq’, namely+ ‘f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’+ In the expression:+ f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord) `eq` f1 x2 y2+ + /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:65:15: error:+ • Couldn't match type ‘'[Tagged "y" (BoolN "y"),+ Tagged "x" (BoolN "x")]’+ with ‘'[]’+ Expected type: Record '[]+ Actual type: HExtendR+ (Tagged "y" (BoolN "y")) (Record '[Tagged "x" (BoolN "x")])+ • In the first argument of ‘f2’, namely+ ‘(ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’+ In the first argument of ‘eq’, namely+ ‘f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’+ In the expression:+ f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2++-} it "f1" $ property $ do (f1 :: BoolN "x" -> BoolN "y") <- arbitrary x :: BoolN "x" <- arbitrary@@ -55,7 +112,7 @@ y :: BoolN "y" <- arbitrary y2 :: BoolN "y" <- arbitrary - let addDef new = hRearrange' (new .<++. [pun| x y |])+ let addDef new = hRearrange (Proxy :: Proxy [Label "x", Label "y"]) (new .<++. [pun| x y |]) f2 (addDef -> [pun| (x y) |]) = f1 x y return $ conjoin [ f2 emptyRecord `eq` f1 x y,
examples/Properties/LengthDependent.hs view
@@ -16,14 +16,24 @@ -- supplied HList isn't known until Properties.LengthDependentSplice) module Properties.LengthDependent where +#if MIN_VERSION_base(4,9,0)+import qualified Data.Kind as DK+#endif import Data.HList.HSort (hMSortBy) import Data.HList.Variant (eqVariant) import Data.HList.Record (hZipRecord2)+import Data.HList.HList (hAppend') import Data.HList.CommonMain +#if MIN_VERSION_template_haskell(2,17,0)+import Language.Haskell.TH.Lib.Internal hiding (doE)+import Language.Haskell.TH (Name, mkName, doE)+#else import Language.Haskell.TH+#endif+ import Test.QuickCheck import Properties.Common import Test.Hspec@@ -72,13 +82,23 @@ |] ] + myForallT :: [Name] -> TypeQ -> TypeQ+#if MIN_VERSION_template_haskell(2,17,0)+ myForallT ns = forallT [ plainInvisTV n inferredSpec | n <- ns ] (cxt [])+#else+ myForallT ns = forallT (map plainTV ns) (cxt [])+#endif quantify :: TypeQ -> TypeQ- quantify ty = forallT [ PlainTV (mkName ("x" ++ show i)) | i <- [1 .. n]] (return []) ty+ quantify = myForallT [ mkName ("x" ++ show i) | i <- [1 .. n]] rss :: [TypeQ] rss = takeK $+#if MIN_VERSION_base(4,9,0)+ [ [t| (Record :: [DK.Type] -> DK.Type) $(hListT (map taggedN ns)) |]+#else [ [t| (Record :: [*] -> *) $(hListT (map taggedN ns)) |]+#endif | ns <- permutations [1 .. fromIntegral n] ] -- taggedN 1 == [t| Tagged 1 x1 |]@@ -111,6 +131,7 @@ x <- genHL True y <- genHL True return $ conjoin [$(varE 'hConcat) ($(varE 'hBuild) x y) == hAppend x y,+ $(varE 'hConcat) ($(varE 'hBuild) x y) == hAppend' x y, $(varE 'hConcat) (hBuild x) == x] it "partition" $@@ -261,14 +282,17 @@ let (x,y) = hUnzip xy return $ xy `eq` hZip x y -#if __GLASGOW_HASKELL__ < 710+ it "hUnzip2/hZip2" $ property $ do+ xy <- genHL (BoolN True :: BoolN "x", BoolN True :: BoolN "y")+ let (x,y) = hUnzip2 xy+ return $ xy `eq` hZip2 x y+ -- XXX doesn't work with ghc-7.10.1 -- (should be fixed for 7.10.2) it "hZip/hZip2" $ property $ do x <- genHL (BoolN True :: BoolN "x") y <- genHL (BoolN True :: BoolN "y") return $ hZip x y `eq` hZip2 x y-#endif -- lots of duplication, not sure if it's worth factoring out it "HList monoid unit" $@@ -322,7 +346,7 @@ s:ss = map sort (permutations xyz) return $ all (s ==) ss -#if __GLASGOW_HASKELL__ > 707+#if __GLASGOW_HASKELL__ > 707 && __GLASGOW_HASKELL__ < 901 -- ghc-7.6 has no ordering for Nat (only for HNat) it "hSort (the labels)" $ property $ do x <- $(rN n1) True@@ -350,6 +374,7 @@ | i <- [1 .. n1], let ln = [| Label :: Label $(litT (numTyLit (fromIntegral i))) |] ])+#if __GLASGOW_HASKELL__ < 901 it "rearranged / hMapR" $ property $ do r <- $(rN n1) True let revR = r & from hListRecord %~ hReverse@@ -357,6 +382,7 @@ asT _ = id -- hMap works on the reversed list return $ hMapR not r === (r & rearranged' . asT revR . unlabeled %~ hMap not)+#endif it "hOccurs" $ property $ do@@ -366,9 +392,14 @@ z <- genHL (BoolN True :: BoolN "z") let xyz = hConcat (hBuild x y z) hxyz = hEnd (hBuild (hHead x) (hHead y) (hHead z))- hM v = hOccursMany xyz === hList2List v++ -- -XNoMonoLocalBinds on ghc <= 7.10.4 allowed+ -- having one function+ hM1 v = hOccursMany xyz === hList2List v+ hM2 v = hOccursMany xyz === hList2List v+ hM3 v = hOccursMany xyz === hList2List v return $ conjoin- [ hM x, hM y, hM z,+ [ hM1 x, hM2 y, hM3 z, hOccurs (hConcat (hBuild x (HCons w HNil) z)) === w, hOccursOpt xyz === (Nothing `asTypeOf` Just w) -- hProject hxyz === hBuild (hHead x) (hHead y)@@ -439,5 +470,3 @@ ] #endif |]--
examples/Properties/LengthDependentSplice.hs view
@@ -1,10 +1,16 @@-{-# OPTIONS_GHC -fcontext-stack=1000 #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# OPTIONS_GHC -freduction-depth=100 #-}+#else+{-# OPTIONS_GHC -fcontext-stack=100 #-}+#endif {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MonoLocalBinds #-} -- maybe it isn't necessary for everything? module Properties.LengthDependentSplice where import Properties.LengthDependent import Language.Haskell.TH@@ -16,11 +22,11 @@ [| describe $(stringE (show n)) $(hl1 n) |] | n <- [1 .. 5]] ++ [ noBindS [| describe $(stringE (show (n1,n2))) $(hl2 n1 n2) |]- | n1 <- [1 .. 3],- n2 <- [1 .. 3] ]+ | n1 <- [1 .. 2],+ n2 <- [1 .. 2] ] ++ [ noBindS [| describe $(stringE (show (n1,n2,n3))) $(hl3 n1 n2 n3) |] | n1 <- [0 .. 2], n2 <- [0 .. 1],- n3 <- [0 .. 2],+ n3 <- [0 .. 1], not $ all (==0) [n1,n2,n3] ] )
examples/Properties/LengthIndependent.hs view
@@ -8,12 +8,17 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-} module Properties.LengthIndependent where import Properties.Common import Control.Lens import Data.HList.CommonMain import Test.Hspec+#if MIN_VERSION_QuickCheck(2,10,1)+import Test.QuickCheck hiding (Fun)+#else import Test.QuickCheck+#endif import Data.Monoid import Data.Maybe import Control.Applicative@@ -311,6 +316,16 @@ hOccurs (HCons True HNil^. from tipHList) `eq` True + it "tipyLens" $ property $ do+ u :: BoolN "u" <- arbitrary+ v :: BoolN "v" <- arbitrary+ w :: BoolN "w" <- arbitrary+ let r = tipHList # hBuild v w+ return $ conjoin+ [ (r & tipyLens %~ ( \ (_ :: BoolN "v") -> u)) `eq` tipHList # hBuild u w,+ (r & tipyLens %~ ( \ (_ :: BoolN "w") -> u)) `eq` tipHList # hBuild v u+ ]+ it "ttip 3" $ do property $ do f <- arbitrary@@ -343,7 +358,12 @@ show v `shouldBe` "[V{x='a'},V{y=\"ly\"}]" read (show v) `shouldBe` v +#if __GLASGOW_HASKELL__ != 802 && __GLASGOW_HASKELL__ != 804+ -- ghc-8.2.1: typeIndexed' has: Couldn't match with ‘*’ with ‘Symbol’+ -- probably a ghc bug as it (1) works in other version (2) works after in-lining show (map (^. typeIndexed') v) `shouldBe` "[TIC{char='a'},TIC{[Char]=\"ly\"}]"+#endif+ show (map (^. simple . typeIndexed . simple) v) `shouldBe` "[TIC{char='a'},TIC{[Char]=\"ly\"}]" it "Data instances gread/gshow" $ do property $ do@@ -431,6 +451,26 @@ ru .!. lz === z, r === ru ^. from unboxedS ] + it "sortForRecordUS" $ do+ property $ do+ a :: Bool <- arbitrary+ b :: (Bool,Bool) <- arbitrary+ c :: Bool <- arbitrary+ d :: (Bool,Bool) <- arbitrary+ let r = [pun| a b c d |]+ sr = sortForRecordUS r+ ssr = sortForRecordUS sr++ return $ conjoin+ [ sr `eq` ssr,+ sr .!. (Label :: Label "a") === a,+ sr .!. (Label :: Label "b") === b,+ sr .!. (Label :: Label "c") === c,+ sr .!. (Label :: Label "d") === d,+ hRearrange' sr === r+ ]++ it "monoid0" $ do mempty `shouldBe` HNil mempty `shouldBe` emptyRecord@@ -502,9 +542,7 @@ return $ conjoin [ v' `eq` (v & hPrism lx %~ not),- tic' `eq` (tic & hLens' (Label :: Label Bool) %~ not),- -- should work, but it doesn't- -- tic' `eq` (tic & hLens' Label %~ not),+ tic' `eq` (tic & hLens' Label %~ not), tic' `eq` (tic & ticPrism %~ not) ] @@ -537,7 +575,9 @@ return $ conjoin [ hUncurry (,,) (hBuild vx vy vz) `eq` (vx,vy,vz), hCurry (hUncurry (,,)) vx vy vz `eq` (vx,vy,vz),+#if __GLASGOW_HASKELL__ > 948 hCurry (hUncurry id) vx `eq` vx,+#endif hCurry ( \(a `HCons` b `HCons` HNil) -> (b,a)) vx vy `eq` (vy,vx) ] @@ -546,9 +586,12 @@ vy :: BoolN "y" <- arbitrary vz :: BoolN "z" <- arbitrary return $ conjoin- [ hCompose (,) (,) vx vy vz `eq` ((vx,vy), vz),- hCompose id (,) vx vy `eq` (vx,vy),- hCompose (,) id vx vy `eq` (vx,vy) ]+ [ hCompose (,) (,) vx vy vz `eq` ((vx,vy), vz)+ , hCompose id (,) vx vy `eq` (vx,vy),+#if __GLASGOW_HASKELL__ > 948+ , hCompose (,) id vx vy `eq` (vx,vy)+#endif+ ] hTuples = do@@ -643,4 +686,3 @@ v2 = fmap (`asLabelsOf` (Proxy :: Proxy '[Label "y"])) (projectVariant v) v_id = fmap (`asLabelsOf` v) (projectVariant v) v_id2 = fmap (`asLabelsOf` labelsOf v) (projectVariant v)-
− examples/TIPTransform.hs
@@ -1,67 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}---- Transforming a TIP: applying to a TIP a (polyvariadic) function--- that takes arguments from a TIP and updates the TIP with the result.--- --- In more detail: we have a typed-indexed collection TIP and we--- would like to apply a transformation function to it, whose argument--- types and the result type are all in the TIP. The function should locate--- its arguments based on their types, and update the TIP--- with the result. The function may have any number of arguments,--- including zero; the order of arguments should not matter.---- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.--- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html--- The problem is an interesting variation of the keyword argument problem.--module TIPTransform where--import Data.HList-import Data.Typeable---- We start with the examples--newtype MyVal = MyVal Int deriving (Show, Typeable)---- or if no typeable, use--- instance ShowLabel MyVal where showLabel _ = "MyVal"---- A sample TIP-tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP--- TIP (HCons (MyVal 20) (HCons 1 (HCons True HNil)))---- Update the Int component of tip1 to 2. The Int component must--- exist. Otherwise, it is a type error-tip2 = ttip (2::Int) tip1--- TIP (HCons (MyVal 20) (HCons 2 (HCons True HNil)))---- Negate the boolean component of tip1-tip3 = ttip not tip1--- TIP (HCons (MyVal 20) (HCons 1 (HCons False HNil)))---- Update the Int component from the values of two other components-tip4 = ttip (\(MyVal x) y -> x+y) tip1--- TIP (HCons (MyVal 20) (HCons 21 (HCons True HNil)))---- Update the MyVal component from the values of three other components-tip5 = ttip (\b (MyVal x) y -> MyVal $ if b then x+y else 0) tip1--- TIP (HCons (MyVal 21) (HCons 1 (HCons True HNil)))---- The same but with the permuted argument order.--- The order of arguments is immaterial: the values will be looked up using--- their types-tip5' = ttip (\b y (MyVal x)-> MyVal $ if b then x+y else 0) tip1--- TIP (HCons (MyVal 21) (HCons 1 (HCons True HNil)))---- The implementation--- part of HList proper now---main = mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4,- show tip5, show tip5']
− examples/TIPTransform.ref
@@ -1,6 +0,0 @@-TIPH[MyVal 20,1,True]-TIPH[MyVal 20,2,True]-TIPH[MyVal 20,1,False]-TIPH[MyVal 20,21,True]-TIPH[MyVal 21,1,True]-TIPH[MyVal 21,1,True]
− examples/TIPTransformM.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-} -- !TF--- Transforming a TIP: applying to a TIP a (polyvariadic) function--- that takes arguments from a TIP and updates the TIP with the result.--- The monadic version.--- This file contains two versions of the code.--- The comments -- !Simple and -- !TF distinguish the versions------ In more detail: we have a typed-indexed collection TIP and we--- would like to apply a transformation function to it, whose argument--- types and the result type are all in the TIP. The function should locate--- its arguments based on their types, and update the TIP--- with the result. The function may have any number of arguments,--- including zero; the order of arguments should not matter.---- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.--- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html--- The problem is an interesting variation of the keyword argument problem.--- In March 2010, Andrew Frank extended the problem for monadic operations.--- This is the monadic version of TIPTransform.hs in the present directory.---module TIPTransformM where--import Data.HList.CommonMain-import Data.Typeable-import Control.Monad.Identity---- We start with the examples--newtype MyVal = MyVal Int deriving (Show,Typeable)---- A specialized version of return for the Identity monad.--- It is needed only for the Simple version of the code,--- to tell the type checker the monad in which the computation is--- taking place.--- For the TF version of the code, we can use the ordinary return--- in place of retI.-retI :: a -> Identity a-retI = return---- A sample TIP-tip1 = MyVal 20 .*. (1::Int) .*. True .*. (3.5::Float) .*. emptyTIP--- TIP (HCons (MyVal 20) (HCons 1 (HCons True (HCons 3.5 HNil))))---- Update the Int component of tip1 to 2. The Int component must--- exist. Otherwise, it is a type error--- tip2 = runIdentity $ ttipM (retI (2::Int)) tip1 -- !Simple-tip2 = runIdentity $ ttipM (return (2::Int)) tip1 -- !TF--- TIP (HCons (MyVal 20) (HCons 2 (HCons True (HCons 3.5 HNil))))----- Negate the boolean component of tip1--- tip3 = runIdentity $ ttipM (retI . not) tip1 -- !Simple-tip3 = runIdentity $ ttipM (return . not) tip1 -- !TF--- TIP (HCons (MyVal 20) (HCons 1 (HCons False (HCons 3.5 HNil))))---- Update the Int component from the values of two other components-tip4 = runIdentity $ ttipM (\(MyVal x) y -> retI $ x+y) tip1--- TIP (HCons (MyVal 20) (HCons 21 (HCons True (HCons 3.5 HNil))))---- Update the MyVal component from the values of three other components-tip5 = runIdentity $ - ttipM (\b (MyVal x) y -> retI $ MyVal $ if b then x+y else 0) tip1--- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))---- The same but with the permuted argument order.--- The order of arguments is immaterial: the values will be looked up using--- their types-tip5' = runIdentity $ - ttipM (\b y (MyVal x)-> retI $ MyVal $ if b then x+y else 0) tip1--- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))---- Andrew Frank's test--- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil)))))-tip6 :: IO (TIP (TagR [MyVal,Int,Bool, Float]))-tip6 = ttipM op6 tip1--op6 :: MyVal -> Bool -> IO MyVal-op6 (MyVal x) b = do- let m = if b then MyVal (x `div` 4) else MyVal (x * 4)- putStrLn $ "MyVal is now " ++ show m- -- ==>> MyVal 5- return m--- TIP (HCons (MyVal 5) (HCons 1 (HCons True (HCons 3.5 HNil))))---{- -- !Simple--- The Simple implementation--- The drawback is the need to let the type checker know the monad in which the--- computations take place. That is why we had to use retI in the above--- code, which is a specialized version of return for the Identity monad. --- In op6, the presence of putStrLn unambiguously specified the monad, viz. IO,--- so no special return are required.--class Monad m => TransTIPM m op db where- ttipM :: op -> db -> m db---- If the operation is the computation in the desired monad,--- the type of the computation must match an element of TIP.-instance (Monad m,- HTypeIndexed db, HUpdateAtHNat n op db db, HType2HNat op db n)- => TransTIPM m (m op) (TIP db) where- ttipM op db = do- op' <- op- return $ tipyUpdate op' db---- If op is not a computation in the desired monad m, --- it must be a function. Look up its argument in a TIP and recur.-instance (Monad m, HOccurs arg db, TransTIPM m op db)- => TransTIPM m (arg -> op) db where- ttipM f db = ttipM (f (hOccurs db)) db--} -- !Simple---- {- -- !TF--- Moved to TIP.hs--- -} -- !TF--main :: IO ()-main = do- mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4,- show tip5, show tip5']- tip2 <- tip6- putStrLn $ "tip2 is" ++ show tip2- return ()-
− examples/TIPTransformM.ref
@@ -1,8 +0,0 @@-TIPH[MyVal 20,1,True,3.5]-TIPH[MyVal 20,2,True,3.5]-TIPH[MyVal 20,1,False,3.5]-TIPH[MyVal 20,21,True,3.5]-TIPH[MyVal 21,1,True,3.5]-TIPH[MyVal 21,1,True,3.5]-MyVal is now MyVal 5-tip2 isTIPH[MyVal 5,1,True,3.5]
− examples/broken/nn.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# OPTIONS_GHC -fcontext-stack=100 #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DataKinds #-}--import Data.HList.CommonMain-import Control.Lens---makeLabelable (unwords [ "r" ++ show n | n <- [0 .. 9 :: Int] ])-r :: RecordU '[Tagged "r0" Int ,- Tagged "r1" Int,- Tagged "r2" Int,- Tagged "r3" Int,- Tagged "r4" Int,- Tagged "r5" Int,- Tagged "r6" Int,- Tagged "r7" Int,- Tagged "r8" Int,- Tagged "r9" Int]-r = [1 .. 10] ^?! listAsHList . from unlabeled . unboxed----main = print $- r^.r0 +- r^.r1 +- r^.r2 +- r^.r3 +- r^.r4 +- r^.r5 +- r^.r6 +- r^.r7 +- r^.r8 +- r^.r9
− examples/cmdargs.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TemplateHaskell #-}-module Main where-import System.Console.CmdArgs-import Data.HList.CommonMain-import Data.Generics-import Control.Lens-import System.Environment-import GHC.TypeLits (Symbol)-import Data.HList.Labelable(LabeledTo,ToSym)--{---An example showing off the data instance for Record / Variant / TIP / TIC--Also a use of cmdArgs--Note that ghc-7.8.2 does not have (or can produce) instances of typeable-for types of kind Symbol (ie. promoted strings):-<https://ghc.haskell.org/trac/ghc/ticket/9111>, so for now use the Label3-style---}--#define USE_LABEL3 __GLASGOW_HASKELL__ == 708--#if USE_LABEL3-makeLabels3 "examples_cmdargs" (words "x y z tic")-makeLabels3 "optV" (words "optA optB optC")-#else--- works for ghc-7.6-makeLabels6 (words "x y z tic")-makeLabels6 (words "optA optB optC")-#endif--makeLabelable "abc df"--#if USE_LABEL3--- XXX remove extra Label?-v = (optA .*. optB .*. optC .*. emptyProxy)- `zipTagged` (Proxy :: Proxy '[Int,Char,Double])-#else-v = Proxy :: Proxy '[Tagged "optA" Int, Tagged "optB" Char, Tagged "optC" Double]-#endif--type Z' = TagR [Int, Char, Double]--d0 = x .=. (5 :: Int)- .*. y .=. True- .*. z .=. mkVariant optC (1 :: Double) v- .*. tic .=. mkTIC' 'x' (Proxy :: Proxy Z')- .*. emptyRecord---- the equivalent ordinary record for reference-data E = E { a :: Int, b :: Bool }- deriving (Show, Data, Typeable)--data Opt = OptA Int | OptB Char | OptC Double- deriving (Show, Data, Typeable)--e0 = E 5 True--main = do- print d0- print $ gmapT (mkT ((+1) :: Double -> Double)) (mkVariant optC 1 v)- print $ (mkVariant optC 1 v)-- print $ gmapT (mkT not) d0- print $ gmapT (mkT (+(1::Int))) d0-- let theB :: Typeable a => a- theB = error "theB"- `extB` (1::Int)- `extB` True- `extB` (2.5::Double)- `extB` 'b'- `extB` mkVariant optC theB v- `extB` mkTIC' (theB :: Char) (Proxy :: Proxy Z')-- print $ fromConstrB theB undefined `asTypeOf` d0-- putStrLn "Cmdargs"- print =<< withArgs ["-a=4", "-b=False" ] (cmdArgs e0)-- -- drop the tic and z fields (which cmdargs doesn't handle)- let dRec = d0 & from hListRecord %~ (hInit . hInit)- print =<< withArgs ["-x=4", "-y=False"] (cmdArgs dRec)
− examples/cmdargs.ref
@@ -1,9 +0,0 @@-Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}-V{optC=2.0}-V{optC=1.0}-Record{x=5,y=False,z=V{optC=1.0},tic=TIC{char='x'}}-Record{x=6,y=True,z=V{optC=1.0},tic=TIC{char='x'}}-Record{x=1,y=True,z=V{optC=2.5},tic=TIC{char='b'}}-Cmdargs-E {a = 4, b = False}-Record{x=4,y=False}
− examples/labelable.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds,- GADTs, ConstraintKinds #-}-{- | Demonstrates @hLens'@--may be worthwhile to have a lens-free test suite, doing stuff like:--> case x (Identity . (++"there")) r of Identity t -> t---}-module Main where-import Data.HList.CommonMain-import Control.Lens--import Text.Read--makeLabelable "x y"--#if __GLASGOW_HASKELL__ < 707-#define INT_SIG_76 :: Int-#else-#define INT_SIG_76-#endif--r = x .==. "hi" .*.- y .==. (y .==. 321 .*. x .==. 123 .*. emptyRecord) .*.- emptyRecord--main = do- print (r ^. x)- print (r & x .~ ())-- -- ghc-7.6 doesn't default when r is involved lower down,- -- while 7.8.2 does- print (r ^. y . y INT_SIG_76)- print (r ^. y . x INT_SIG_76)-- print (r & y . y .~ "xy")-- putStrLn "\nread-show"- print (readMaybe (show r) `asTypeOf` Just r)- print (readMaybe "Record{x=\"hi\",y=Record{y=321,x=123}}" `asTypeOf` Just r)-- -- there is no permuting of labels- print (readMaybe "Record{y=Record{y=321,x=123},x=\"hi\"}" `asTypeOf` Just r)-- print $ (r ^. rearranged) `asTypeOf` (undefined :: Record '[Tagged "y" t, Tagged "x" s])
− examples/labelable.ref
@@ -1,11 +0,0 @@-"hi"-Record{x=(),y=Record{y=321,x=123}}-321-123-Record{x="hi",y=Record{y="xy",x=123}}--read-show-Just Record{x="hi",y=Record{y=321,x=123}}-Just Record{x="hi",y=Record{y=321,x=123}}-Nothing-Record{y=Record{y=321,x=123},x="hi"}
− examples/lens.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds #-}-{- | Demonstrates @hLens@. See also labelable.hs which is more "convenient"---}-module Main where-import Data.HList.CommonMain-import Control.Lens--makeLabels6 (words "x y z")---#if __GLASGOW_HASKELL__ > 707-yRec = y .=. 321 .*. x .=. 123 .*. emptyRecord-#else--- defaulting doesn't work in ghc-7.6.3-yRec = y .=. (321 :: Integer) .*. x .=. (123 :: Integer) .*. emptyRecord-#endif--r = x .=. "hi" .*.- y .=. yRec .*.- emptyRecord---_ = (r^.y') `asTypeOf` hRearrange'- (x .=. 1 .*. y .=. 1 .*. emptyRecord)--rSmall = x .=. "" .*. emptyRecord--x' a = hLens x a-y' a = hLens y a--main = do- print (view (hLens x) r)- print (set (hLens x) () r)-- print (r ^. hLens y . hLens x)- print (r & hLens y . hLens y .~ "xy")--- putStrLn "\n\nand repeat:"-- -- and now for with hLens applied second- print (view x' r)- print (set x' () r)-- print (r ^. y' . y')- print (r & y' . y' .~ "xy")-- putStrLn "\n\nIsos"- print (r & sameLength . unlabeled . hTuple . _1 .~ ())- print (r & sameLength . unlabeled . hTuple . _2 .~ ())- print (z .=. () .*. r- & unlabeled' . from tipHList %~ ttip (\x z -> x ++ show (z :: ())))-- r ^. unlabeled . from tipHList & tipPutStrLn---tipPutStrLn tip = ttipM ?? tip $ \x -> do- putStrLn x- return x
− examples/lens.ref
@@ -1,19 +0,0 @@-"hi"-Record{x=(),y=Record{y=321,x=123}}-123-Record{x="hi",y=Record{y="xy",x=123}}---and repeat:-"hi"-Record{x=(),y=Record{y=321,x=123}}-321-Record{x="hi",y=Record{y="xy",x=123}}---Isos-Record{x=(),y=Record{y=321,x=123}}-Record{x="hi",y=()}-Record{z=(),x="hi()",y=Record{y=321,x=123}}-hi-TIPH["hi",Record{y=321,x=123}]
− examples/prism.hs
@@ -1,120 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE QuasiQuotes #-} -- for pun-{-# LANGUAGE TemplateHaskell #-}-module Main where-import Data.HList.CommonMain-import Data.HList.Labelable (hLens')-import Control.Lens---- generate left = Label :: Label "left"-makeLabels6 (words "left right up down")----- define the Labelable labels manually-left_ = hLens' left-right_ = hLens' right-up_ = hLens' up-down_ = hLens' down---- this definition is needed to decide what order--- to put the fields in, as well as their initial types-r = [pun|right left up|] where- left = 'a'- right = 2 :: Int- up = 2.3 :: Double--v = mkVariant left 'x' r--main = do- putStrLn "Lookup and set"- inspectV-- putStrLn "\nrepeat with Labelable"- inspectV_-- putStrLn "\nSetting the missing tag does nothing:"- print $ set right_ () v- Left 'x' <- set _Right () (Left 'x') -- prisms for Either do the same thing- & return-- putStrLn "\nLenses compose:"- Nothing <- v3 ^? up_.up_ & return- Just 'x' <- v3 ^? left_ & return- v4 ^? left_.left_ & print-- putStrLn "\nLenses+prisms compose:"- inspectRV-- putStrLn "\n\"extension\""- extensionTests-- putStrLn "\nInternal Structure:"- putStrLn $ indent $ show vs----lazyX = mkVariant (Label :: Label "x") 'a' lazyProto-lazyY = mkVariant (Label :: Label "y") (2.5 :: Double) lazyProto--lazyProto = undefined :: Record- '[Tagged "x" x, Tagged "y" y]--vs = [pun| v v2 v2' v3 v4 v5 v6 v7 |]--inspectV = do- v ^? hPrism left & print- v ^? hPrism right & print- v ^? hPrism up & print- v2 ^? hPrism left & print---- note that we can change the type of the 'x' field--- from Char to ()-v2 = set (hPrism left) () v--inspectV_ = do- v ^? left_ & print- v ^? right_ & print- v ^? up_ & print- v2' ^? left_ & print---inspectRV = do- r2 ^? down_.left_ & print- r2 ^? down_.right_ & print- r2 ^? du & print--du = down_.up_--r2 = down_ .==. v .*. r----- or with the "better" label-v2' = set left_ () v---v3 = v & up_ .~ v & up_.up_ .~ "upup"-v4 = v & left_ .~ v & left_.left_ .~ "leftleft"---extensionTests = do- Just "hi" <- v5 ^? down_ & return- Just "hi" <- v6 ^? down_ & return- Nothing <- v7 ^? down_ & return- Just 'x' <- v7 ^? left_ & return- return ()---v5 = down .=. Just "hi" .*. v-v6 = down_ .==. Just "hi" .*. v-v7 = down .=. (Nothing :: Maybe String) .*. v---- start a newline after every } to make the results readable-indent :: String -> String-indent xs = indent' 0 xs--indent' n xs | n < 0 = indent' 0 xs-indent' n ('}' : xs) = "}\n" ++ replicate n ' ' ++ indent' (n-4) xs-indent' n ('{' : xs) = '{' : indent' (n+4) xs-indent' n (x : xs) = x : indent' n xs-indent' _ [] = []
− examples/prism.ref
@@ -1,37 +0,0 @@-Lookup and set-Just 'x'-Nothing-Nothing-Just ()--repeat with Labelable-Just 'x'-Nothing-Nothing-Just ()--Setting the missing tag does nothing:-V{left='x'}--Lenses compose:-Just "leftleft"--Lenses+prisms compose:-Just 'x'-Nothing-Nothing--"extension"--Internal Structure:-Record{v=V{left='x'}- ,v2=V{left=()}- ,v2'=V{left=()}- ,v3=V{left='x'}- ,v4=V{left=V{left="leftleft"}- }- ,v5=V{down="hi"}- ,v6=V{down="hi"}- ,v7=V{left='x'}- }-
− examples/pun.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}--- more examples for record puns-module Main where-import Data.HList.CommonMain--makeLabels6 (words "a b c")---r = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord-r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord---p1 ( (.!. b) -> (b @ ((.!. a) -> a))) = (a,b)--p2 [pun| b @ {a} |] = (a, b)---- same as p2, but gives a warning--- p3 [pun| b @ a |] = (a, b)--p4 [pun| b{a} |] = a -- b is not bound---- adds `x' and `y' into a field called r-e1 = let x = 1; y = "hi" in [pun| r @ { x y } |]---- updates the `c' field-e2 = let c = 1; y = "hi" in [pun| r @ { c y } |]---- same as e1, but doesn't use a pre-existing r-e3 = let x = 1; y = "hi" in [pun| r { x y } |]---main = do- putStrLn "similar:"- print $ p1 r- print $ p2 r- print $ p4 r-- putStrLn "\nexpression QQ:"- print $ e1- print $ e2- print $ e3-
− examples/pun.ref
@@ -1,9 +0,0 @@-similar:-(3,Record{a=3})-(3,Record{a=3})-3--expression QQ:-Record{r=Record{x=1,y="hi",c="c",b=Record{a=3}}}-Record{r=Record{c=1,y="hi",b=Record{a=3}}}-Record{r=Record{x=1,y="hi"}}
− examples/runexamples.hs
@@ -1,59 +0,0 @@-module Main where--import Cabal-import Control.Exception-import System.FilePath-import Test.Hspec-import System.Exit-import System.Process-import System.Directory-import Data.Maybe-import Control.Monad--main = do- es <- getDirectoryContents "examples"- print es- -- very dumb- es <- filterM (\e -> allM- [return (takeExtension e == ".hs"),- doesFileExist (dropExtension ("examples"</>e) ++ ".ref") ]) es-- print es-- hspec $ do- mapM_ runghcwith es---runghcwith f = describe f $ it "ok" $- do- let ex = ("examples" </>)- let inFile = ex (takeBaseName f)- outFile = dropExtension inFile ++ ".out"- errFile = dropExtension inFile ++ ".err"- refFile = dropExtension inFile ++ ".ref"-- (ec, stdout, stderr) <- cabal- ["repl","examples",- "-v0", "--ghc-options", "-w -fcontext-stack=50 -iexamples -v0"]- (":set -i\n:set -iexamples\n:load " ++ inFile ++ "\nmain")-- writeFile outFile stdout-- ofe <- doesFileExist refFile- diff <- if ofe- then fmap Just $- readProcess "diff" ["-b", outFile, refFile] ""- `finally` writeFile errFile stderr- else return Nothing-- unless (diff == Just "") $ writeFile errFile stderr-- return (ec, stderr, diff)- `shouldReturn` (ExitSuccess, "", Just "")----allM [] = return True-allM (x:xs) = do- x <- x- if x then allM xs else return False