HList 0.4.2.0 → 0.5.0.0

raw patch · 66 files changed

+2224/−2104 lines, 66 filesdep +hspec-expectationsdep +semigroupsdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: hspec-expectations, semigroups

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog +26/−0
• Data/HList/CommonMain.hs +40/−16
• Data/HList/Data.hs +19/−3
• Data/HList/Dredge.hs +399/−0
• Data/HList/FakePrelude.hs +54/−11
• Data/HList/HArray.hs +13/−8
• Data/HList/HList.hs +51/−14
• Data/HList/HListPrelude.hs +41/−0
• Data/HList/HOccurs.hs +20/−14
• Data/HList/HSort.hs +5/−4
• Data/HList/Labelable.hs +45/−15
• Data/HList/MakeLabels.hs +9/−1
• Data/HList/Record.hs +32/−23
• Data/HList/RecordU.hs +4/−5
• Data/HList/TIC.hs +4/−2
• Data/HList/TIP.hs +70/−20
• Data/HList/Variant.hs +14/−2
• Data/HList/broken/VariantOld.hs +0/−68
• HList.cabal +51/−16
• LensDefs.hs +18/−2
• README +10/−8
• examples/Cabal.hs +0/−50
• examples/Datatypes1.hs +0/−14
• examples/Datatypes2.hs +0/−19
• examples/FooBar.hs +0/−27
• examples/HListExample.hs +47/−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 +203/−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/Common.hs +24/−0
• examples/Properties/KW.hs +63/−1
• examples/Properties/LengthDependent.hs +9/−2
• examples/Properties/LengthDependentSplice.hs +4/−3
• examples/Properties/LengthIndependent.hs +41/−3
• 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

@@ -1,3 +1,29 @@+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 

@@ -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# 

@@ -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 $

@@ -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)++

@@ -10,14 +10,19 @@  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 import Control.Applicative #if NEW_TYPE_EQ import Data.Type.Equality (type (==))@@ -28,7 +33,7 @@ #endif  #if __GLASGOW_HASKELL__ < 709-import Data.Monoid+import Data.Monoid (Monoid(..)) #endif  @@ -285,7 +290,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 +687,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 +772,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 

@@ -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

@@ -5,9 +5,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@@ -21,6 +18,7 @@ import LensDefs  import Data.Array (Ix)+import Data.Semigroup  -- -------------------------------------------------------------------------- -- * Heterogeneous type sequences@@ -490,7 +488,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 +993,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 +1095,7 @@ -- | @Prism' [a] (HList s)@ -- -- where @s ~ HReplicateR n a@-listAsHList' x = simple (listAsHList (simple x))+listAsHList' x = isSimple listAsHList x   -- --------------------------------------------------------------------------@@ -1354,6 +1352,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 +1381,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 +1416,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 = ()@@ -1601,6 +1631,10 @@             $ (hProxies :: HList (AddProxy a))   mappend a b = hMap UncurryMappend $ hZip a b +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 +1646,7 @@ 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 (<>) 

@@ -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  

@@ -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   -- --------------------------------------------------------------------------

@@ -92,7 +92,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@@ -208,7 +209,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,14 +229,14 @@ 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 :: [*]) 

@@ -33,7 +33,7 @@     LabeledCxt1,     LabeledTo(LabeledTo),     LabeledR(LabeledR),-    ToSym(toLabel),+    ToSym, EnsureLabel(toLabel), toLabelSym,     Identity,     LabelableTIPCxt,     LabeledOpticType(..),@@ -112,7 +112,19 @@  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@@ -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  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@@ -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

@@ -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) |] 

@@ -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,6 +198,7 @@ import LensDefs  import Data.Array (Ix)+import Data.Semigroup (Semigroup)  -- imports for doctest/examples import Data.HList.Label6 ()@@ -246,6 +249,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 +265,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 +326,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 +404,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 +470,15 @@ 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),++          -- 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 +602,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 +738,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 +840,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 +1072,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 +1111,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 +1251,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 +1283,7 @@               HZip Proxy lts vs tvs)       => Proxy ts -> proxy vs -> Proxy tvs zipTagged _ _ = Proxy+#endif   

@@ -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

@@ -24,6 +24,7 @@ import Data.HList.HArray  import Data.Array (Ix)+import Data.Semigroup (Semigroup)  import Text.ParserCombinators.ReadP import LensDefs@@ -41,6 +42,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 +54,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 +110,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)

@@ -20,11 +20,16 @@ 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)+import Data.Semigroup (Semigroup) ++#if __GLASGOW_HASKELL__ > 710+import Data.Coerce+#endif+ import LensDefs  -- --------------------------------------------------------------------------@@ -34,6 +39,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 +140,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 +158,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 +263,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 +282,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 +293,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 +318,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 +398,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 +410,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 +450,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 +471,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"  -- -------------------------------------------------------------------------- 

@@ -27,9 +27,9 @@ import Text.ParserCombinators.ReadP hiding (optional)  import Unsafe.Coerce-import GHC.Prim (Any) import GHC.Exts (Constraint) +import Data.Semigroup (Semigroup( .. )) import Data.Data import Control.Applicative import LensDefs@@ -738,6 +738,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,7 +913,18 @@  -- * 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@@ -919,7 +932,6 @@                     (l, r) -> mkVariant (Label :: Label t) (mappend l r) Proxy  --- | XXX check this mappend is legal instance (Monoid x, Monoid (Variant (a ': b))) => Monoid (Variant (Tagged t x ': a ': b)) where     mempty = extendVariant mempty     mappend a b = case (splitVariant1 a, splitVariant1 b) of

@@ -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!>"--

@@ -1,5 +1,5 @@ Name:                HList-Version:             0.4.2.0+Version:             0.5.0.0 Category:            Data Synopsis:            Heterogeneous lists Description:         HList provides many operations to create and manipulate@@ -7,9 +7,13 @@                      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@@ -22,25 +26,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==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1, GHC==8.4.0.20180209 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 +54,11 @@                See <https://ghc.haskell.org/trac/ghc/ticket/9918>  library-  Build-Depends:       base >= 4.6 && < 4.9,+  Build-Depends:       base >= 4.6 && < 4.12,                        -- for Typeable '[] and '(:) with ghc-7.6                        base-orphans,+                       -- Data.Semigroup for ghc < 8+                       semigroups,                        template-haskell,                        ghc-prim,                        mtl,@@ -69,6 +70,7 @@   Exposed-modules:     Data.HList,                        Data.HList.CommonMain,                        Data.HList.Data,+                       Data.HList.Dredge,                        Data.HList.FakePrelude,                        Data.HList.HArray,                        Data.HList.HCurry,@@ -119,6 +121,8 @@   Other-Extensions:    CPP                        TemplateHaskell                        OverlappingInstances+  if impl(ghc >= 8.0)+    Default-Extensions: UndecidableSuperClasses    if impl(ghc < 7.7)     Cpp-options:       -DOLD_TYPEABLE -DNO_CLOSED_TF@@ -136,27 +140,49 @@  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+                       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.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, doctest >= 0.8, process+  Buildable: False   Main-Is: rundoctests.hs   Hs-Source-Dirs:  examples-  Build-Depends: base, doctest >= 0.8, process   Default-Language:    Haskell2010  @@ -164,6 +190,7 @@   Type:     exitcode-stdio-1.0   Build-Depends: base,                  hspec >= 1.7,+                 hspec-expectations,                  HList,                  lens,                  mtl,@@ -171,6 +198,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

@@ -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 &

@@ -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,17 +36,18 @@ 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.+for GHC-7.6, 7.8, 7.10, 8.2 and 8.4.0.20180209.+Older compilers are not supported.  One may run "cabal test" to check the distribution. 

@@ -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

@@ -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)

@@ -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)

@@ -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--

@@ -0,0 +1,47 @@+{-# 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+++main = hspec $ do+  mainCmdargs+  mainLabelable+  mainGhcGeneric1+  mainPosting051106+  mainPrism+  mainPun+  mainTIPTransform+  mainTTIPM++++++

@@ -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}"+

@@ -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)

@@ -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

@@ -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

@@ -0,0 +1,203 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+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.++-}

@@ -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

@@ -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\"}}"+

@@ -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

@@ -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"+

@@ -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

@@ -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"

@@ -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"-             )---{-----------------------------------------------------------------------------}

@@ -1,1 +0,0 @@-(HTrue,HFalse)

@@ -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

@@ -1,4 +0,0 @@-X is zero-something else-something else-X is zero

@@ -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->---}

@@ -1,1 +0,0 @@-(H[MyImplementation1 10,MyImplementation2 20],(True,(True,(False,False))))

@@ -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.---}

@@ -1,2 +0,0 @@-8
-8

@@ -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),@@ -127,8 +147,12 @@     mempty = BoolN (getAll mempty)     mappend (BoolN x) (BoolN y) = BoolN (getAll (mappend (All x) (All y))) +instance Semigroup (BoolN n) where (<>) = mappend++#if !MIN_VERSION_QuickCheck(2,9,0) instance Arbitrary (Identity (BoolN n)) where     arbitrary = fmap return arbitrary+#endif   data HSortF = HSortF

@@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-} module Properties.KW where  @@ -17,6 +18,66 @@   kwSpecs = describe "kw" $ do++#if (__GLASGOW_HASKELL__ > 799)+    return ()+    {- 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++-}+#else     it "f1" $ property $ do       (f1 :: BoolN "x" -> BoolN "y") <- arbitrary       x :: BoolN "x" <- arbitrary@@ -55,7 +116,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,@@ -65,3 +126,4 @@           f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2         ] +#endif

@@ -20,6 +20,7 @@ import Data.HList.HSort (hMSortBy) import Data.HList.Variant (eqVariant) import Data.HList.Record (hZipRecord2)+import Data.HList.HList (hAppend') import Data.HList.CommonMain  @@ -111,6 +112,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" $@@ -366,9 +368,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)

@@ -5,6 +5,7 @@ {-# 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 +17,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] ]   )

@@ -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)       ] 

@@ -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']

@@ -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]

@@ -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 ()-

@@ -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]

@@ -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

@@ -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)

@@ -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}

@@ -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])

@@ -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"}

@@ -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

@@ -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}]

@@ -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' _ [] = []

@@ -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'}-        }-    

@@ -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-

@@ -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"}}

@@ -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