packages feed

HList 0.3.4.1 → 0.5.4.0

raw patch · 93 files changed

Files

ChangeLog view
@@ -1,3 +1,235 @@+20 Feb 2025+0.5.4 Release+Merge Daniil's Itskov's changes:+	Add files for building with nix+	Build with ghc-9.10.1+Remove tests for hCurry and hCompose where ghc-9.4.8 has poor type inference+not seen in newer versions.++23 Sep 2023+0.5.3 Release+Build with ghc-9.4.6 and ghc-9.6.1.+ghc-9.4.6 cannot compile examples/Properties/LengthIndependent.hs+as some types cannot be inferred. This is fixed in ghc-9.6.1.++18 Feb 2022+0.5.2 Release+Remove custom Setup.lhs which was for ghc-7.6++Change to pun quasiquote improves error messages:+  For `f [pun| x y |] = ()`+  f :: _ => r (a ': b ': c) -> ()  -- old+  f :: _ => r as -> ()             -- new+Previously if you supplied a 9 element record to a function+needing 10 elements, the error would not name the missing field.+It is possible but unlikely that the old code will need to a type+annotation like+(id :: HLengthGE x (HSucc (HSucc HZero)) => r x -> r x)++23 Oct 2021+0.5.1 Release+Build & pass tests with ghc-8.4.4 through 9.2.0.20210821,+though with 9.2.0.20210821 dependencies for tests need+cabal flags --allow-newer=base --allow-newer=template-haskell,+and also invariant-functors and lens from git (as specified in `cabal.project`)++Add examples/HListExample/OverloadedLabels.hs++19 Feb 2018+0.5.0 Release+Build & pass tests with ghc-7.6 through 8.4.0.20180209++Add Dredge.hs (ghc>=7.8): access nested records/variants given only the last+label along a path++Move toLabel to another class to allow it to return Labels with+kinds other than Symbol.++tipyLens can now change the element type++Add hTake and hDrop++Use TypeError for prettier error messages in ghc-8.0 (still backwards+compatible)++Improve HFind and HUpdateAtHNat error messages by mentioning the whole+record being changed++22 Dec 2015+0.4.2 Release++Depend on base-orphans to avoid multiple definitions of Typeable '[],+Typeable '(:)++3 Aug 2015+0.4.1 Release++Add RecordU.hs, a record type with elements stored in unboxed arrays++Documentation fixes (Thor Michael Støre)++5 May 2015+0.4 Release++16 Apr 2015+Make tests run (and pass) when called by "runghc Setup test"++Add hNot, and add HNotFD which is injective (unlike the type family)++Replace uses of `HLength xs ~ n` with `HLengthEq xs n`.++15 Mar 2015+Add HCurry.hs.++Redefine Arity such that `Arity f (HSucc HZero)` will refine the+type of `f` to `x -> y`.++SameLabels is generalized so that functions like 'asLabelsOf' do+not need to explicitly convert a that specifies the ordering of+labels. Additional constraints might be needed to restore the old+behavior:++> type SameLabelsOld x y = (HAllTaggedLV x, HAllTaggedLV y, SameLabels x y)++Similarly HExtend instances Proxy intended for making Proxies+used to disambiguate labels (see 'asLabelsOf' again).++Add hMapOutV, zipVR, extendsVariant. Rename the previous+splitVariant to splitVariant1, and use the name splitVariant for+a function that splits a Variant into two Variants.++Add projected to Labelable.hs which allows working on a smaller+Record or Variant.++Add HasFieldM for lookups that return a default value if the+field is missing.++Split HZip into two classes: class HUnzip r x y xy => HZip r x y xy.+This allows instance HUnzip Variant x y xy.++Add Data,Typeable,Enum,Bounded,Ord,Monoid instances for Variant and TIC++Implement HRLabelSet in terms of HLabelSet, which simplifies+inferred types that would otherwise have redundancy (HLabelSet+(LabelsOf r), HRLabelSet r)++Move definitions into FakePrelude, and split up+examples/Properties.hs into separate modules to help with+compilation times when adding new tests.++15 Feb 2015+Change HList to a data family (see comments in HList.hs).++Change the Show instance for TIP and HList to use "," not ", " as the+separator for consistency with Record and ordinary lists.++Parameterize HZip over the collection type to work on Record, TIP as well as+HList.++Add and use HProxies for building the spine of a HList from the type, to avoid+having HLists of undefined/error values somewhere.++Build with ghc-7.10 RC1. RecordU/RecordUS is moved to broken/ instead of+updating it.++9 Sep 2014+Change the ordering of the list produced by HLeftUnion / (.<++.)+to better match hAppend / ++ suggested by the name.++25 Aug 2014+Add HSort, which provides a merge sort and a quick sort.++Support _ (wildcard) with the pun quasiquoter, and make+patterns such as [pun| x y _ |] constrain the Record or Variant+to have at least 3 elements.++Reduce the number of parameters for Labelable++Allow operations with different label kinds (ie.+Record [Tagged 1 x, Tagged "y" Int]) to proceed as expected.++13 Jul 2014+Start RecordU and RecordUS, a variation on Record where the values+are stored in unboxed array(s).++Add Partition, GroupBy and Span.++Add list2HList and isos sameLength and sameLabels.++23 Jun 2014+TIPTransform and TIPTransformM become part of the distribution,+and missing fields are reported with the Fail superclass+technique.++Projection of a TIP to a tuple is reimplemented without an explicit+type signature. The functions are exported as tipyTuple,+tipyTuple3 etc.++Conversion between HLists and up to 6-tuples done with HTuple.++Add ZipVariant, Unvariant, splitVariant, extendVariant,+an instance Eq (Variant v) and an instance Labelable TIC.++Add quickcheck in examples/Properties.hs. Coverage measured with+HPC is about 40%.++5 Jun 2014+Start to parameterize operations on the collection type. This+means that where we previously had HMapCxt f x y another+type parameter with kind [*] -> * is added. This means+previous uses of HMapCxt f x y become HMap HList f x y.+This allows hMap to be used with Record and Variant.+HUpdateAtLabel is similarly generalized.++Rework Variant: the implementation is now similar to Dynamic+and TIC. Likewise, TIP is implemented in terms of Record.++28 May 2014+Add tipyLens and ticPrism.++Add a HExtend instance for Variant.++Add functional dependencies to Labelable (and corresponding+superclasses) to avoid ambiguous types.++26 May 2014+Add prisms for Variant. This adds a dependency on "profunctors".++Parameterize Labelable on the collection type. This allows+labelable labels to be used with RecordS or VariantS, where+the resulting Optic is a Lens or Prism respectively.++Remove recordLabels in favor of labelsOf: a kind variable which+only appears on the RHS required a lengthy type annotation to fix+that variable. Pattern matching to convert a `Label (a :: k)` to+`a :: k` happens later on when another value with kind `k` is a+available on the LHS.++Improve type errors when accessing missing fields when using+Labelable labels. Except for HPrism, the error message contains+`Fail (FieldNotFound "x")`. This involved adding a HUpdateAtLabel+class and HTPupdateAtLabel type which hides the `n` type+variable.++Reduce the number of parameters to HMapCxt. The old version could+be defined in terms of the new version as:++	type HMapCxt_old f a b ha hb = (HMapCxt f a b,+																	HList a ~ ha,+																	HList b ~ hb)++Reimplement RecordValues in terms of HMap. The original+implementation is kept because it avoids the need for+-XAllowAmbiguousTypes.++Add hMapR and hMapV to map over the values in a Record or the+value in a Variant respectively. These functions are defined in+terms of HFmap which may be useful on it's own.++Add a typeable instance for Label3, and change examples/cmdargs.hs+to use this label kind. This allows the example to work with+ghc-7.8.2 which lacks an instance Typeable (x :: Symbol).+ 28 Mar 2014 	Release 0.3.4.1 	Fix build with ghc-7.8 broken by changes in HList 0.3.4
Data/HList/CommonMain.hs view
@@ -11,43 +11,191 @@  module Data.HList.CommonMain ( + -- * Faking dependent types in Haskell    module Data.HList.FakePrelude++ -- * Functions for all collections  , module Data.HList.HListPrelude+ -- * Array-like access to HLists  , module Data.HList.HArray+ -- * Result-type-driven operations  , module Data.HList.HOccurs+ -- * Type-indexed operations  , module Data.HList.HTypeIndexed++ -- * Record  , module Data.HList.Record+ -- | quasiquoter 'pun' helps to avoid needing a proxy value with+ -- type 'Label' in the first place: when you take values out of or into+ -- records with pattern matching, the variable name determines the label+ -- name.+ , module Data.HList.RecordPuns++ -- ** Unpacked / Unboxed Records+ , RecordU+ , RecordUS+ , SortForRecordUS(..)+ , HUpdateMany(..)+ , hMapRU++ -- *** internals for types+ , HFindMany, HNats2Integrals(..)++ , RecordUSCxt+ , HLookupByHNatUS, HLookupByHNatUS1+ , HSubtract, HMapUnboxF, UnboxF+ , BoxF, EqTagValue, GetElemTy, ElemTyEq+ , RecordToRecordU, RecordUToRecord++ -- * HList+ -- | A subset of "Data.HList.HList" is re-exported.  , module Data.HList.HList- , module Data.HList.TypeEqO- , module Data.HList.TIP- , module Data.HList.TIC  , module Data.HList.HZip- , module Data.HList.Variant+ -- ** A subset of "Data.HList.HSort"+ , hSort+ , HSort+ , HSortBy(..)+ , HLeFn, HDown+ , HSet, HSetBy+ , HIsSet, HIsSetBy+ , HAscList, HIsAscList + -- ** A subset of "Data.HList.HCurry"+ , HCurry'(..)+ , hCurry, hUncurry+ , hCompose++ -- * TIP+ -- | Public interface of "Data.HList.TIP"+ , TIP+ , emptyTIP+ , tipyUpdate+ , tipyLens+ , tipyLens'+ -- ** projection+ , tipyProject+ , tipyProject2+ , tipyTuple+ , tipyTuple3+ , tipyTuple4+ , tipyTuple5+ , TagUntag, TagUntagFD(..)+ , TagR++ -- ** TIP transform+ , TransTIP(..)+ , TransTIPM(..)++ -- * TIC+ -- | Public interface of "Data.HList.TIC"+ , TIC+ -- ** creating TIC+ , mkTIC+ , mkTIC1+ , mkTIC'++ -- ** get,set,modify+ , ticPrism, ticPrism'++ -- * Variant+ -- | Public interface of "Data.HList.Variant"+ , Variant+ , mkVariant+ , mkVariant1+ , castVariant+ , HMapV(..), hMapV+ , hMapOutV+ , ZipVariant(..)+ , ZipVR(..), zipVR+ -- ** projection+ -- *** many+ , SplitVariant(splitVariant)+ , ProjectVariant(..)+ , ExtendsVariant(..)+ , ProjectExtendVariant(..)+ -- *** one+ , HPrism(..)+ , unvarianted, unvarianted'++ , splitVariant1+ , splitVariant1'+ , extendVariant+ -- **** implementation+ , Unvariant(..)+ , Unvariant'(..)++++ -- * Conversions between collections+ -- $convention the foo' optic has the same type as+ -- @Control.Lens.simple . foo . Control.Lens.simple@.+ -- 'hLens'' is an exception to this rule.++ , TypeIndexed(..)+ , typeIndexed'+ -- ** HList and Record+ -- | 'unlabeled' 'unlabeled''++ -- ** HList and TIP+ , tipHList, tipHList'+ -- ** Record and RecordU+ , unboxed, unboxed'+ -- ** Record and RecordUS+ , unboxedS, unboxedS'+ -- ** Record and Variant+ , hMaybied, hMaybied'++ -- ** Newtype wrappers+ -- $convention these isos unwrap/wrap the newtypes 'TIP' 'TIC' and+ -- 'Record'. Names follow the pattern @fromTo :: Iso' From To@.++ -- | 'hListRecord' 'hListRecord'' are exported under "Data.HList.Record"+ , ticVariant, ticVariant'+ , tipRecord, tipRecord'++ -- *** implementation+ , VariantToHMaybied(variantToHMaybied)+ , HMaybiedToVariantFs+ , hMaybiedToVariants+  -- * "Data.HList.Keyword"  -- | the \"public\" parts. More examples are in the module documentation.  , Kw(..), recToKW, IsKeyFN, K,  ErrReqdArgNotFound,  ErrUnexpectedKW   -- * Labels- {- | there are really only two options for now, but 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. 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: -   See 'makeLabels6' for automating the @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@@ -55,21 +203,34 @@  , module Data.HList.Labelable  -- $labelable + -- ** "Data.HList.Dredge"+ -- *** lenses+ , dredge, dredge'+ , dredgeND, dredgeND'+ , dredgeTI'+ -- *** plain lookup+ , hLookupByLabelDredge, HasFieldPath+  -- ** namespaced labels  , module Data.HList.Label3 - -- | template haskell for automating different types of labels+ -- ** labels as any instance of Typeable+ --  | "Data.HList.Label5"++ -- ** template haskell  , module Data.HList.MakeLabels- -- | quasiquoter 'pun' helps to avoid needing a proxy value with- -- type 'Label' in the first place: when you take values out of or into- -- records with pattern matching, the variable name determines the label- -- name.- , module Data.HList.RecordPuns    -- * "Data.HList.Data"  -- | This modules provide useful instances. A useful application can be  -- found in @examples/cmdargs.hs@++ -- | Overlapping instances are restricted to here+ , module Data.HList.TypeEqO++ -- * Internals+ -- | internals exported for type signature purposes+ , HAllTaggedEq ) where  import Data.HList.FakePrelude@@ -78,16 +239,31 @@ import Data.HList.HOccurs import Data.HList.HTypeIndexed import Data.HList.Record-import Data.HList.HList+-- import Data.HList.RecordOrd+import Data.HList.HList hiding (append',+                                hAppend',+                                FHCons(..),+                                hMapAux,+                                MapCar(..),+                                hMapMapCar,+                                hSequence2,+                                )+import Data.HList.HCurry+import Data.HList.HSort import Data.HList.MakeLabels-import Data.HList.TypeEqO+import Data.HList.TypeEqO hiding (IsKeyFN) import Data.HList.TIP import Data.HList.TIC  import Data.HList.HZip-import Data.HList.Label3+import Data.HList.Label3 hiding (MapLabel)+import Data.HList.Label5 () -- only instances import Data.HList.Label6 () -- only instances-import Data.HList.Labelable+import Data.HList.Labelable (Labelable(..),+                             Projected(..), projected',+                             toLabel,+                             (.==.),+                             LabeledOptic)  import Data.HList.Variant @@ -95,7 +271,10 @@  import Data.HList.Keyword import Data.HList.RecordPuns+import Data.HList.RecordU +import Data.HList.Dredge+ {- $label6demo #label6demo#   Instances from "Data.HList.Label6"@@ -114,12 +293,14 @@ {- $labelable #labelabledemo#  Rather than having the @x = Label :: Label \"x\"@, the labels-generated by 'makeLabelable' also double lenses for "Control.Lens".+generated by 'makeLabelable' also double as lenses for "Control.Lens". Here is an example of how much better that is:  >>> :set -XNoMonomorphismRestriction -XDataKinds -XPolyKinds >>> import Control.Lens+>>> import Data.HList.Labelable >>> let x = hLens' (Label :: Label "x")+>>> let y = hLens' (Label :: Label "y")  The Label6 method: @@ -137,6 +318,13 @@  >>> r & x .~ () Record{x=()}++When a field is missing, the error names that field:++>>> :t r^.y+...+...No instance for (Fail (FieldNotFound "y"))+...  -}
Data/HList/Data.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-} -{- | 'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend+{- | Description: Data instances+++'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend to be flat data structures. The @Data@ instance for 'HList' gives a nested structure. -NOTE: these instances do not work with ghc-7.8 because of-<http://ghc.haskell.org/trac/ghc/ticket/8486>+NOTE: these instances do not work with ghc-7.8 with promoted+string (Symbol) labels because of+<https://ghc.haskell.org/trac/ghc/ticket/9111>  [@HList@] @@ -48,50 +52,57 @@     -- * exports for type signatures/ haddock usage     DataHListFlatCxt,     DataRecordCxt,-    TypeRepsList,+    TypeRepsList(..),      -- ** less likely to be used     RecordLabelsStr(..),     GfoldlK(..),     GunfoldK(..),     HListFlat(..),+    TypeablePolyK,     ) where  import Data.HList.FakePrelude import Data.HList.HList import Data.HList.Record-import GHC.TypeLits+import Data.HList.Variant import Data.Data-import Data.List-import GHC.Exts (Constraint)--import Unsafe.Coerce+import Data.HList.TIC+import Data.HList.TIP +-- for Typeable '[] and Typeable '(:) with ghc-7.6+import Data.Orphans () -instance (Data x, Data (HList xs), Typeable (HList (x ': xs)),-        TypeablePolyK (x ': xs))-        => Data (HList (x ': xs)) where-    gfoldl k z (HCons a b) = (z HCons `k` a) `k` b-    gunfold k z _ = k (k (z HCons))+#if OLD_TYPEABLE+import Data.List+#endif -    dataTypeOf _ = hListDataRep-    toConstr _   = hConsConRep+import Unsafe.Coerce  -instance (TypeablePolyK ('[] :: [*])) => Data (HList '[]) where-    gfoldl _k z HNil = z HNil-    gunfold _k z _ = z HNil-    dataTypeOf _ = hListDataRep-    toConstr _   = hNilConRep+deriving instance Typeable (HList '[]) => Data (HList '[])+deriving instance+    (Data x,+     Data (HList xs),+     TypeablePolyK (x ': xs), -- for new typeable+     Typeable (HList (x ': xs) -- for old typeable+     )) => Data (HList (x ': xs)) -hListDataRep = mkDataType "Data.HList.HList" [hConsConRep, hNilConRep]-hConsConRep = mkConstr hListDataRep "HCons" [] Prefix-hNilConRep = mkConstr hListDataRep "HNil" [] Prefix+deriving instance+    (TypeablePolyK xs,+     Typeable (HList xs),+     Data (HList xs)) => Data (TIP xs)+deriving instance+    (TypeablePolyK xs,+     Typeable (Variant xs),+     Data (Variant xs)) => Data (TIC xs)  -- | this data type only exists to have Data instance newtype HListFlat a = HListFlat (HList a) -type DataHListFlatCxt 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)),@@ -99,12 +110,28 @@         HFoldr             (GunfoldK C)             (C g)-            (HReplicateR (HLength a) ())+            (HReplicateR na ())             (C (HList a)), -        HReplicate (HLength a) ())+        HLengthEq a na,+        HReplicate na ()) -instance DataHListFlatCxt g a => Data (HListFlat a) where++-- | 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 $                     hFoldl                         (c1 (GfoldlK k))@@ -182,7 +209,7 @@     recordLabelsStr _ = [] instance (RecordLabelsStr xs,           ShowLabel x) => RecordLabelsStr (Tagged x t ': xs) where-    recordLabelsStr _ = showLabel (undefined :: Label x) :+    recordLabelsStr _ = showLabel (Label :: Label x) :                             recordLabelsStr (undefined :: Record xs)  {- |@@ -202,8 +229,8 @@     recordLabelsStr2 _ = [] instance (RecordLabelsStr2 xs,           ShowLabel x) => RecordLabelsStr2 (x ': xs) where-    recordLabelsStr2 _ = showLabel (undefined :: Label x) :-                            recordLabelsStr2 (undefined :: proxy xs)+    recordLabelsStr2 _ = showLabel (Label :: Label x) :+                            recordLabelsStr2 (Proxy :: Proxy xs)   -- | use only with @instance Data (HList a)@. This is because the HFoldl@@ -212,13 +239,18 @@ data C a  -- typeable isntances... either hand written or derived when possible-#if MIN_VERSION_base(4,7,0)+#if !OLD_TYPEABLE deriving instance Typeable Record deriving instance Typeable HList deriving instance Typeable HListFlat--- deriving instance Typeable Tagged+deriving instance Typeable Variant+deriving instance Typeable TIC+deriving instance Typeable TIP -type TypeablePolyK (a :: k) = (Typeable a)+-- orphans+deriving instance Typeable 'HZero+deriving instance Typeable 'HSucc+ #else instance TypeRepsList (Record xs) => Typeable (HList xs) where    typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.HList" "HList")@@ -228,48 +260,59 @@   typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "Record")                 [ tyConList (typeRepsList x) ] +instance TypeRepsList (Record xs) => Typeable (Variant xs) where+  typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Variant" "Variant")+                [ tyConList (typeRepsList (error "Data.HList.Data:Typeable Variant" :: Record xs)) ]++instance Typeable (Variant xs) => Typeable (TIC xs) where+  typeOf (TIC xs) = mkTyConApp (mkTyCon3 "HList" "Data.HList.TIC" "TIC")+                      [typeOf xs]++instance Typeable (HList xs) => Typeable (TIP xs) where+  typeOf (TIP xs) = mkTyConApp (mkTyCon3 "HList" "Data.HList.TIP" "TIP")+                      [typeOf xs]+ instance ShowLabel sy => Typeable1 (Tagged sy) where   typeOf1 _ = mkTyConApp-        (mkTyCon3 "HList" "Data.HList.Data" (showLabel (undefined :: Label sy)))+        (mkTyCon3 "HList" "Data.HList.Data" (showLabel (Label :: Label sy)))         []  instance (ShowLabel sy, Typeable x) => Typeable (Tagged sy x) where   typeOf _ = mkTyConApp-            (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (undefined :: Label sy)))+            (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label sy)))             [mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "=") [],-                    typeOf (undefined :: x)+                    typeOf (error "Data.HList.Data:Typeable Tagged" :: x)                     ] -type TypeablePolyK a = (() :: Constraint) - instance Typeable (HList a) => Typeable (HListFlat a) where     typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Data" "HListFlat")             [typeOf (error "Typeable HListFlat" :: HList a)]-#endif -- -- pretty-prints sort of like a real list tyConList xs = mkTyConApp open ( intersperse comma xs ++ [close] )     where     open = mkTyCon3 "GHC" "GHC.TypeLits" "["     close = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" "]") []     comma = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" ",") []+#endif  +++ class TypeRepsList a where   typeRepsList :: a -> [TypeRep]  -instance (TypeRepsList (Prime xs), ConvHList xs) => TypeRepsList (Record xs) where-  typeRepsList (Record xs) = typeRepsList (prime xs)+instance (TypeRepsList (HList xs)) => TypeRepsList (Record xs) where+  typeRepsList (Record xs) = typeRepsList xs -instance (TypeRepsList xs, Typeable x) => TypeRepsList (HCons' x xs) where-  typeRepsList (~(x `HCons'` xs))+instance (TypeRepsList (HList xs), Typeable x) => TypeRepsList (HList (x ': xs)) where+  typeRepsList (~(x `HCons` xs))         = typeOf x : typeRepsList xs -instance TypeRepsList HNil' where+instance TypeRepsList (HList '[]) where   typeRepsList _ = []
+ Data/HList/Dredge.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+-- TryCollectionList needs overlap+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+{- | Description: access nested records/variants given only the last label along a path -}+module Data.HList.Dredge where++import Data.HList.Record+import Data.HList.Variant+import Data.HList.HList+import Data.HList.TIP+import Data.HList.TIC+import Data.HList.FakePrelude+import Data.HList.Labelable+import LensDefs (isSimple)+import Data.HList.TypeEqO () -- if this is missing, dredge fails+++#if (__GLASGOW_HASKELL__ == 800)+-- https://ghc.haskell.org/trac/ghc/ticket/13371+toLabelx x = toLabelSym x+#else+toLabelx x = toLabel x+#endif++{- |++Using HListPP syntax for short hand, @dredge `foo@ expands out to+something like @`path . `to . `foo@, with the restriction that+there is only one possible @`path .  `to@ which leads to the+label @foo@.++For example, if we have the following definitions,++> type BVal a = Record '[Tagged "x" a, Tagged "a" Char]+> type R a = Record  [Tagged "a" Int, Tagged "b" (BVal a)]+> type V a = Variant [Tagged "a" Int, Tagged "b" (BVal a)]+> lx = Label :: Label "x"++Then we have:++> dredge `x :: Lens (R a) (R b) a b+> dredge lx :: Lens (R a) (R b) a b++> dredge `x :: Traversal (V a) (V b) a b -- there were only variants along the path we'd get a Prism+> dredge lx :: Traversal (V a) (V b) a b++[@result-type directed operations are supported@]++There are two ways to access a field with tag @a@ in the R type+defined above, but they result in fields with different types+being looked up:++> `a        :: Lens' (R a) Char+> `b . `a   :: Lens' (R a) Int++so provided that the result type is disambiguated by the context,+the following two types can happen++> dredge `a :: Lens' (R a) Char+> dredge `a :: Lens' (R a) Int+++[@TIP & TIC@]++type indexed collections are allowed along those paths, but+as explained in the 'Labelable' instances, only simple optics+(Lens' / Prism' / Traversal' ) are produced. @dredgeTI'@+works better if the target is a TIP or TIC++-}+dredge label = getSAfromOutputOptic $ \ pr pa ->+      hLens'Path (labelPathEndingWithTD pr (toLabelx label) pa)++++getSAfromOutputOptic :: (p a fb -> p rs rft) ~ stab+                => (Proxy (rs :: *) -> Proxy (a :: *) -> stab) -> stab+getSAfromOutputOptic f = f Proxy Proxy+++-- | 'dredge' except a simple (s ~ t, a ~ b) optic is produced+dredge' label = isSimple (dredge label)+++-- | dredgeND (named directed only) is the same as 'dredge', except the+-- result type (@a@) is not used when the label would otherwise+-- be ambiguous. dredgeND might give better type errors, but otherwise+-- there should be no reason to pick it over dredge+dredgeND label = getSAfromOutputOptic $ \ pr _a ->+      hLens'Path (labelPathEndingWith pr (toLabelx label))+++-- | 'dredgeND' except a simple (s ~ t, a ~ b) optic is produced+dredgeND' label = isSimple (dredgeND label)+++{- | The same as dredgeND', except intended for TIP/TICs because+the assumption is made that @l ~ v@ for the @Tagged l v@ elements.+In other words, ticPrism' and 'tipyLens'' could usually+be replaced by++> dredgeTI' :: _ => Label a -> Lens'  (TIP s) a+> dredgeTI' :: _ => Label a -> Prism' (TIC s) a++where we might have @s ~ '[Tagged a a, Tagged b b]@++-}+dredgeTI' label = isSimple lens where+        lens = getSAfromOutputOptic $ \ pr pa ->+            hLens'Path (labelPathEndingWith pr (pa `proxyTypeOf` label))++        proxyTypeOf :: p a -> q a -> Label a+        proxyTypeOf _ _ = Label+++-- | @HSingleton msg xs x@ is like @'[x] ~ xs@ if that constraint can hold,+-- otherwise it is @Fail msg@. See comments on 'Fail' about how its kind+-- varies with ghc version.+class HSingleton (msgAmb :: m) (msgEmpty :: m2) (ns :: [k]) (p :: k) | ns -> p+instance HSingleton m1 m2 '[n] n+instance (Fail m2, Any ~ a) => HSingleton m1 m2 '[] a+instance (Fail m1, Any ~ a) => HSingleton m1 m2 (n1 ': n2 ': n3) a+++-- | @HGuardNonNull msg xs@ is like @when (null xs) (fail msg)@+class HGuardNonNull emptymsg (xs :: [k])++instance Fail msg => HGuardNonNull msg '[]+instance             HGuardNonNull msg (x ': xs)+++-- | @ConsTrue b x xs r@ is like @r = if b then x:xs else xs@+class ConsTrue (b :: Bool) (x :: k) (xs :: [k]) (r :: [k]) | b x xs -> r, r b -> xs, x xs r -> b+instance ConsTrue True x xs (x ': xs)+instance ConsTrue False x xs xs++-- | @FilterLastEq x xs ys ys'@ determines ys' such that it+-- contains all of the @ys !! i@ such that @last (xs !! i) == x@.+-- In other words it is like+--+-- > ys' = [ y |  (xsElt, y) <- zip xs ys, last xsElt == x ]+class FilterLastEq (x :: k) (xs :: [[k]]) (ys :: [m]) (ys' :: [m]) | x xs ys -> ys'+instance (HReverse path (y' ': rest), HEq y y' b, ConsTrue b z r1 r,+          FilterLastEq y xs zs r1) => FilterLastEq y (path ': xs) (z ': zs) r++instance FilterLastEq y '[] '[] '[]++-- | The same as 'FilterLastEq' except @id@ is used instead of @last@+class FilterVEq (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'++instance FilterVEq v '[] '[] '[]++instance+   (HEq v v' b,+    ConsTrue b n ns1 ns2,+    FilterVEq v vs ns ns1)+    => FilterVEq v (v' ': vs) (n ': ns) ns2++-- | like @FilterVEq@, except if there is+class FilterVEq1 (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'+instance (v ~ v') => FilterVEq1 v '[ v' ] ns ns+instance FilterVEq1 v '[] '[] '[]+instance FilterVEq v (a ': b ': c)  ns ns' => FilterVEq1 v (a ': b ': c) ns ns'++-- | @LabelPathEndingWith r l path@+--+-- determines a unique path suitable for 'hLookupByLabelPath'+-- (calling 'Fail' otherwise) through the+-- nested records/variants in r ending with l+class LabelPathEndingWith (r :: *) (l :: k) (path :: [*]) | r l -> path where+    labelPathEndingWith :: proxy r -> Label l -> Label path+    labelPathEndingWith _ _ = Label++instance+   (FieldTree r ns,+    FilterLastEq (Label l) ns ns ns',+    HSingleton (NonUnique' r l) (NamesDontMatch r ns l) ns' path)+    => LabelPathEndingWith r l path+++labelPathEndingWithTD :: forall r l v path+                                vs vs1 ns ns1 ns2.+   (SameLength ns vs,+    SameLength ns1 vs1,+    FieldTree r ns,+    FieldTreeVal r vs,+    FilterLastEq (Label l) ns ns ns1,+    FilterLastEq (Label l) ns vs vs1,+    FilterVEq1 v vs1 ns1 ns2,++    HGuardNonNull (NamesDontMatch r ns l) ns1,++    -- '[path] ~ ns2, plus error reporting if ns2 has >1 or 0 elements+    HSingleton (NonUnique r v l) (TypesDontMatch r ns1 vs1 v) ns2 path)+    => Proxy r -> Label l -> Proxy v -> Label path+labelPathEndingWithTD _ _ _ = Label+++type NamesDontMatch r ns l = ErrShowType r+  :$$: ErrText "has paths"  :<>: ErrShowType ns+  :$$: ErrText "but none which end in the desired label" :<>: ErrShowType l++type NonUnique' r l = ErrText "Path ending in label " :<>: ErrShowType l+  :$$: ErrText "is not unique in " :<>: ErrShowType r++type NonUnique r v l = NonUnique' r l+  :$$: ErrText "also considering the v type " :<>: ErrShowType v++{- | XXX++> let x = 'x'; y = [pun| x |]; z = [pun| y |]+> z & dredge (Label :: Label "x") %~ (succ :: Int -> Int)++Should reference this type error, but for whatever reason it doesn't++-}+type TypesDontMatch r ns1 vs1 v = ErrShowType r+  :$$: ErrText "has potential paths with the right labels" :<>: ErrShowType ns1+  :$$: ErrText "which point at types" :<>: ErrShowType vs1 :<>: ErrText "respectively"+  :$$: ErrText "but none of these match the desired type" :<>: ErrShowType v++-- | see 'hLookupByLabelPath'+hLookupByLabelDredge l r = labelPathEndingWith (toProxy r) l `hLookupByLabelPath` r+  where toProxy :: r x -> Proxy x+        toProxy _ = Proxy++{- | lookup along a path++>>> let v = mkVariant1 Label (mkVariant1 Label 'r') :: Variant '[Tagged "x" (Variant '[Tagged "y" Char])]+>>> let r = hBuild (hBuild 'r') :: Record '[Tagged "x" (Record '[Tagged "y" Char])]+>>> let p = Label :: Label [Label "x", Label "y"]+>>> let lx = Label :: Label "y"++>>> hLookupByLabelPath p v+Just 'r'++>>> hLookupByLabelPath p r+'r'++>>> hLookupByLabelDredge lx v+Just 'r'++>>> hLookupByLabelDredge lx r+'r'++-}+hLookupByLabelPath :: HasFieldPath False ls r v => Label ls -> r -> v+hLookupByLabelPath labels r = hLookupByLabelPath1 hFalse labels r++{- |++> hLens'Path labc == hLens' la . hLens' lb . hLens' lc+>  where+>       la :: Label "a"+>       lb :: Label "b"+>       lc :: Label "c"+>       labc :: Label '["a", "b", "c"]++-}+class LabelablePath (xs :: [*]) apb spt | spt xs -> apb where+    hLens'Path :: Label xs -> apb -> spt++instance (Labelable x r s t a b,+          j ~ (a `p` f b),+          k ~ (r s `p` f (r t)),+          ty ~ LabelableTy r,+          LabeledOpticP ty p,+          LabeledOpticF ty f,+          LabeledOpticTo ty x (->),+          LabelablePath xs i j) => LabelablePath (Label x ': xs) i k where+    hLens'Path _ = (hLens' (Label :: Label x) :: j -> k) . hLens'Path (Label :: Label xs)++instance (x ~ x') => LabelablePath '[] x x' where+    hLens'Path _ = id++class HasFieldPath (needJust :: Bool) (ls :: [*]) r v | needJust ls r -> v where+    -- | use 'hLookupByLabelPath' instead+    hLookupByLabelPath1 :: Proxy needJust -> Label ls -> r -> v++instance HasFieldPath False '[] v v where+    hLookupByLabelPath1 _ _ = id++instance HasFieldPath True '[] v (Maybe v) where+    hLookupByLabelPath1 _ _ = Just++instance (HasField l (Record r) u, HasFieldPath needJust ls u v)+    => HasFieldPath needJust (Label l ': ls) (Record r) v where+     hLookupByLabelPath1 needJust _ = hLookupByLabelPath1 needJust (Label :: Label ls)+                                . hLookupByLabel (Label :: Label l)++instance (HasField l (Variant r) (Maybe u), HasFieldPath True ls u (Maybe v))+    => HasFieldPath needJust (Label l ': ls) (Variant r) (Maybe v) where+     hLookupByLabelPath1 _ _ v = hLookupByLabelPath1 hTrue (Label :: Label ls) =<< hLookupByLabel (Label :: Label l) v++++++{- | @(FieldTree r ns, FieldTreeVal r vs)@++defines ns and vs such that looking up path (ns !! i) in r gives the type+(vs !! i). This is almost @HasFieldPath False (ns !! i) (vs !! i)@, except+there is no additional Maybe when a Variant is encountered along the path+(and we don't have a type level @!!@)+-}+class FieldTreeVal (r :: *) (v :: [*]) | r -> v++class MapFieldTreeVal (r :: *) (ns :: Maybe [*]) (vs :: [*]) | r ns -> vs++instance (TryCollectionList r ns, MapFieldTreeVal r ns v) => FieldTreeVal r v++instance MapFieldTreeVal r Nothing '[]++instance ( MapFieldTreeVal r (Just xs) out2,+           FieldTreeVal v out1,+           (v ': HAppendListR out1 out2) ~ out)+  => MapFieldTreeVal r (Just (Tagged n v ': xs))  out++instance MapFieldTreeVal r (Just '[]) '[]++{- | list all paths through nested records or variants.+An example instance would be++> FieldTree r v++where++> v ~ [[ Label "x",  Label Dat ], '[Label "y"], '[Label "x"] ]+> r ~ Record [ Tagged "x" x, Tagged "y" String ]+>+> x ~ Variant '[ Tagged Dat Char ]++-}+class FieldTree (r :: *) (v :: [[*]]) | r -> v++-- | the only instance+instance (TryCollectionList r ns, MapFieldTree ns vs) => FieldTree r vs+++#if (__GLASGOW_HASKELL__ >= 800)+-- possibly https://ghc.haskell.org/trac/ghc/ticket/13284+-- dredge' x = (isSimple . dredge) x+--     • Overlapping instances for TryCollectionList r0 ns0+--         arising from a use of ‘dredge’+--       Matching instances:+--         instance [overlappable] nothing ~ 'Nothing =>+--                                 TryCollectionList x nothing+--           -- Defined at /home/aavogt/wip/HList/HList/Data/HList/Dredge.hs:340:31+--         ...plus four instances involving out-of-scope types+--         (use -fprint-potential-instances to see them all)+--       (The choice depends on the instantiation of ‘r0, ns0’+--        To pick the first instance above, use IncoherentInstances+--        when compiling the other instance declarations)+--+-- attempt to resolve that with a closed type family++type family TryCollectionListTF (r :: *) :: Maybe [*] where+  TryCollectionListTF (Record r) = Just r+  TryCollectionListTF (Variant r) = Just r+  TryCollectionListTF (TIC r) = Just r+  TryCollectionListTF (TIP r) = Just r+  TryCollectionListTF nothing = Nothing++type TryCollectionList r v = (v ~ TryCollectionListTF r)++#else+-- | try to extract the list applied to the Record or Variant+class TryCollectionList (r :: *) (v :: Maybe [*]) | r -> v++instance {-# OVERLAPPABLE #-} (nothing ~ Nothing) => TryCollectionList x nothing+instance {-# OVERLAPPING  #-} TryCollectionList (Record  r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (Variant r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (TIC r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (TIP r) (Just r)+#endif++class MapFieldTree (ns :: Maybe [*]) (vs :: [[*]]) | ns -> vs++instance MapFieldTree Nothing '[]++-- | recursive case+instance (+    MapFieldTree (Just xs) vs3,+    FieldTree v vs1,+    MapCons (Label n) ('[] ': vs1) vs2,+    HAppendListR vs2 vs3 ~ vs)+    => MapFieldTree (Just (Tagged n v ': xs)) vs++instance MapFieldTree (Just '[]) '[]++-- | MapCons x xs xxs is like  xxs = map (x : ) xs+class MapCons (x :: k) (xs :: [[k]]) (xxs :: [[k]]) | x xs -> xxs+instance MapCons x '[] '[]+instance MapCons x b r => MapCons x (a ': b) ( (x ':  a) ': r)++
Data/HList/FakePrelude.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE OverlappingInstances #-}--- just for the proxy+{-# LANGUAGE CPP #-}  {- |    The HList library@@ -11,31 +10,77 @@  module Data.HList.FakePrelude     (module Data.HList.FakePrelude,-     module Data.Proxy) where+     -- * re-exports+     module Data.Proxy,+     module Data.Tagged,+     Monoid(..),+     Any) where  import Data.Proxy-import GHC.Prim (Constraint)+import Data.Tagged+import GHC.Exts (Constraint,Any) import GHC.TypeLits+#if __GLASGOW_HASKELL__ >= 800+import qualified GHC.TypeLits as Data.HList.FakePrelude (ErrorMessage((:$$:), (:<>:))) -- XXX check this works?+#endif+#if __GLASGOW_HASKELL__ <= 906+import Control.Applicative+#endif+#if NEW_TYPE_EQ+import Data.Type.Equality (type (==))+#endif +#if !OLD_TYPEABLE+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ < 709+import Data.Monoid (Monoid(..))+#endif++ -- -------------------------------------------------------------------------- -- * A heterogeneous apply operator  -- | simpler/weaker version where type information only propagates forward--- with this one. 'app' defined below, is more complicated / verbose to define,+-- with this one. 'applyAB' defined below, is more complicated / verbose to define, -- but it offers better type inference. Most uses have been converted to--- 'app', so there is not much that can be done with 'Apply'.+-- 'applyAB', so there is not much that can be done with 'Apply'. class Apply f a where   type ApplyR f a :: *   apply :: f -> a -> ApplyR f a-  apply = undefined                     -- In case we use Apply for-                                        -- type-level computations only  {- $note - Polymorphic functions are not first-class in haskell. One solution is to- write an instance of 'ApplyAB' for a data type that takes the place of- the original function. In other words,+ Polymorphic functions are not first-class in haskell. An example of this+ is: + > f op = (op (1 :: Double), op (1 :: Int))++ [@RankNTypes@]++ One solution is to enable `-XRankNTypes` and then write a type+ signature which might be `f :: (forall a. Num a => a -> a)`. This+ does not work in the context of HList, since we want to use functions+ that do not necessarily fall into the pattern of (forall a. c a => a -> a).++ [@MultipleArguments@]++ Another solution is to rewrite @op@ to look like++ > f op1 op2 = (op1 (1:: Double), op2 (1 :: Int))++ In some sense this approach works (see HZip), but the result+ is constrained to as many function applications as you are willing to+ write (ex. a function that works for records of six entries would+ look like @hBuild f f f f f f@).+++ [@Defunctionalization@]++ Therefore the selected solution is to write an instance of 'ApplyAB' for a data+ type that takes the place of the original function. In other words,+  > data Fn = Fn  > instance ApplyAB Fn a b where applyAB Fn a = actual_fn a @@ -56,15 +101,54 @@  The first instance allows types to be inferred as if we had  @class ApplyAB a b c | a -> b c@, while the second instance  only matches if ghc already knows that it needs- @ApplyAB Fn Int Double@. Additional explanation can be found+ @ApplyAB Fn Int Double@. Since @applyAB Fn :: Int -> Double@+ has a monomorphic type, this trimmed down example does not+ really make sense because @applyAB (fromIntegral :: Int -> Double)@+ is exactly the same. Nontheless, the other uses of @ApplyAB@+ follow this pattern, and the benefits are seen when the type of+ @applyAB Fn@ has at least one type variable.++ Additional explanation can be found  in <http://okmij.org/ftp/Haskell/typecast.html#local-fd local functional dependencies> ++ [@AmbiguousTypes@]++ Note that ghc only allows AllowAmbiguousTypes when a type+ signature is provided. Thus expressions such as:++ > data AddJust = AddJust+ > instance (y ~ Maybe x) => ApplyAB AddJust x y where+ >    applyAB _ x = Just x+ >+ > twoJustsBad = hMap AddJust . hMap AddJust -- ambiguous type++ Are not accepted without a type signature that references the+ intermediate \"b\":++ > twoJusts :: forall r a b c. (HMapCxt r AddJust a b, HMapCxt r AddJust b c) =>+ >        r a -> r c+ > twoJusts a = hMap AddJust (hMap AddJust a :: r b)++ An apply class with functional dependencies++ > class ApplyAB' f a b | f a -> b, f b -> a++ Or with equivalent type families++ > class (GetB f a ~ b, GetA f b ~ a) => ApplyAB' f a b++ would not require an annotation for @twoJusts@. However,+ not all instances of ApplyAB will satisfy those functional+ dependencies, and thus the number of classes would proliferate.+ Furthermore, inference does not have to be in one direction+ only, as the example of 'Data.HList.HList.HMap' shows.+ -}  -- | No constraints on result and argument types class ApplyAB f a b where   applyAB :: f -> a -> b-  applyAB = undefined -- In case we use Apply for type-level computations only   {- $fun@@ -84,10 +168,15 @@  constraints on the argument type:   >>> :set -XDataKinds- >>> let plus1 = Fun (\x -> if x < 5 then x+1 else 5) :: Fun '[Num, Ord] '()+ >>> let plus1f x = if x < 5 then x+1 else 5+ >>> let plus1 = Fun plus1f :: Fun '[Num, Ord] '()  >>> :t applyAB plus1- applyAB plus1 :: (Num a, Ord a) => a -> a+ applyAB plus1 :: (Num b, Ord b) => b -> b + >>> let xs = [1 .. 8]+ >>> map (applyAB plus1) xs == map plus1f xs+ True+  Also note the use of @'()@ to signal that the result  type is the same as the argument type. @@ -96,7 +185,7 @@   >>> let succ1 = Fun succ :: Fun Enum '()  >>> :t applyAB succ1- applyAB succ1 :: Enum a => a -> a+ applyAB succ1 :: Enum b => b -> b    >>> let just = Fun Just :: Fun '[] Maybe@@ -203,7 +292,7 @@ -} data HComp g f = HComp g f -- ^ @g . f@ -instance forall f g a b c. (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where+instance (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where     applyAB ~(HComp g f) x = applyAB g (applyAB f x :: b)  @@ -230,7 +319,7 @@  -- | (\(a,b) -> f a >> b) newtype HSeq x = HSeq x-instance (Monad m, ApplyAB f x fx, fx ~ m (), pair ~ (x,m ()), +instance (Monad m, ApplyAB f x fx, fx ~ m (), pair ~ (x,m ()),           ApplyAB f x (m ()) ) => ApplyAB (HSeq f) pair fx where   applyAB (HSeq f) (x,c) = do asVoid (applyAB f x); c     where asVoid :: m () -> m ()@@ -249,17 +338,45 @@ instance (f1 ~ (a -> b -> c), f2 ~ (b -> a -> c))  => ApplyAB HFlip f1 f2 where     applyAB _ = flip ++-- | 'fmap'+newtype HFmap f = HFmap f++instance (x ~ t a,+          y ~ t b,+          Functor t,+          ApplyAB f a b) =>+  ApplyAB (HFmap f) x y where+    applyAB (HFmap f) = fmap (applyAB f)+++-- | 'liftA2'+newtype LiftA2 f = LiftA2 f++instance (ApplyAB f (x,y) z,+          mz ~ m z,+          mxy ~ (m x, m y),+          Applicative m) => ApplyAB (LiftA2 f) mxy mz where+    applyAB (LiftA2 f) xy = liftA2 (curry (applyAB f)) `uncurry` xy+++-- | 'untag'+data HUntag = HUntag+instance (Tagged t x ~ tx) => ApplyAB HUntag tx x where+    applyAB _ (Tagged x) = x++ -- -------------------------------------------------------------------------- -- * Proxy -- --- $note see "Data.HList.Proxy"+-- $note see "Data.Proxy"  -- | A special 'Proxy' for record labels, polykinded data Label l = Label  labelToProxy :: Label l -> Proxy l-labelToProxy = undefined+labelToProxy _ = Proxy  class ShowLabel l where   showLabel :: Label l -> String@@ -290,11 +407,8 @@ -}  -- ** Value-level proxies-hTrue  :: Proxy True ; hTrue  = undefined-hFalse :: Proxy False; hFalse = undefined--instance Show (Proxy True)  where show _ = "HTrue"-instance Show (Proxy False) where show _ = "HFalse"+hTrue  :: Proxy True ; hTrue  = Proxy+hFalse :: Proxy False; hFalse = Proxy   -- **  Conjunction@@ -305,7 +419,7 @@  -- | `demote' to values hAnd :: Proxy t1 -> Proxy t2 -> Proxy (HAnd t1 t2)-hAnd = undefined+hAnd _ _ = Proxy   -- ** Disjunction@@ -316,7 +430,7 @@  -- | `demote' to values hOr :: Proxy t1 -> Proxy t2 -> Proxy (HOr t1 t2)-hOr = undefined+hOr _ _ = Proxy  {- $boolHistoricalNote @@ -343,7 +457,19 @@ >   hOr _ _ = hTrue -} +type family HNot (x :: Bool) :: Bool+type instance HNot True = False+type instance HNot False = True +-- | as compared with 'HNot' this version is injective+class HNotFD (b :: Bool) (nb :: Bool) | b -> nb, nb -> b+instance HNotFD True False+instance HNotFD False True++hNot :: HNotFD a notA => Proxy a -> Proxy notA+hNot _ = Proxy++ class HCond (t :: Bool) x y z | t x y -> z  where   hCond :: Proxy t -> x -> y -> z@@ -376,23 +502,51 @@ data HNat = HZero | HSucc HNat  -hZero :: Proxy HZero; hZero = undefined-hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = undefined-hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = undefined+hZero :: Proxy HZero; hZero = Proxy+hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = Proxy+hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = Proxy  class HNat2Integral (n::HNat) where     hNat2Integral :: Integral i => Proxy n -> i +type family HNat2Nat (n :: HNat) :: Nat+type instance HNat2Nat HZero = 0+type instance HNat2Nat (HSucc n) = 1 + HNat2Nat n++#if MIN_VERSION_base(4,7,0)+{- Instead convert HNat to GHC.TypeLits.'Nat' with 'HNat2Nat' and use functions+from that module to produce the 'Integer' -}+instance KnownNat (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (natVal (Proxy :: Proxy (HNat2Nat n)))+#else+{- doesn't work: gives "No instance for (SingI Nat (1 + (1 + 0)))"+instance SingI (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (fromSing (sing :: Sing (HNat2Nat n)))+-}++-- | a slow (at runtime) implementation for ghc 7.6: instance HNat2Integral HZero where     hNat2Integral _ = 0  instance HNat2Integral n => HNat2Integral (HSucc n) where     hNat2Integral n = hNat2Integral (hPred n) + 1+#endif -instance HNat2Integral n => Show (Proxy (n :: HNat)) where -    show n = "H" ++ show (hNat2Integral n :: Integer) +class HNats2Integrals (ns :: [HNat]) where+    hNats2Integrals :: Integral i => Proxy ns -> [i] +instance HNats2Integrals '[] where+    hNats2Integrals _ = []++instance (HNats2Integrals ns,+          HNat2Integral n)+  => HNats2Integrals (n ': ns) where+    hNats2Integrals _ = hNat2Integral (Proxy :: Proxy n) :+                        hNats2Integrals (Proxy :: Proxy ns)+++ -- | Equality on natural numbers -- (eventually to be subsumed by the universal polykinded HEq) type family HNatEq (t1 :: HNat) (t2 :: HNat) :: Bool@@ -412,9 +566,26 @@ type instance HLt (HSucc n) (HSucc n') = HLt  n n'  hLt :: Proxy x -> Proxy y -> Proxy (HLt x y)-hLt = undefined+hLt _ _ = Proxy  +-- | Less than or equal to+type family HLe (x :: HNat) (y :: HNat) :: Bool++type instance HLe HZero HZero          = True+type instance HLe (HSucc x) y          = HLt x y++hLe :: Proxy x -> Proxy y -> Proxy (HLe x y)+hLe _ _ = Proxy++-- | @HDiv2 x@ behaves like @x `div` 2@+type family HDiv2 (x :: HNat) :: HNat+type instance HDiv2 HZero = HZero+type instance HDiv2 (HSucc HZero) = HZero+type instance HDiv2 (HSucc (HSucc a)) = HSucc (HDiv2 a)+++ -- -------------------------------------------------------------------------- -- * Maybies -- $maybiesNote We cannot use lifted Maybe since the latter are not populated@@ -430,17 +601,49 @@ -- for the sake of the generic equality. class HEq (x :: k) (y :: k) (b :: Bool) | x y -> b --- Equality instances for naturals+-- | Equality for types that may have different kinds. This definition+-- allows operations on @Record [Tagged \"x\" a, Tagged 2 b]@ to work+-- as expected.+type HEqK (x :: k1) (y :: k2) (b :: Bool) = HEq (Proxy x) (Proxy y) b -instance HEq HZero HZero     True-instance HEq HZero (HSucc n) False-instance HEq (HSucc n) HZero False-instance HEq  n n' b => HEq (HSucc n) (HSucc n') b+#if NEW_TYPE_EQ+-- | Uses @(==) :: * -> * -> Bool@ because+-- there is no polykinded instance of (==),+-- since that one overlaps "more productive"+-- instances that pattern match on types.+instance ((Proxy x == Proxy y) ~ b) => HEq x y b+#endif  hEq :: HEq x y b => x -> y -> Proxy b-hEq =  undefined+hEq _ _ = Proxy  +-- | this class generalizes HEq by allowing the choice of @f@ to allow+-- equating only part of x and y+class HEqByFn f => HEqBy (f :: t) (x :: k) (y :: k) (b :: Bool) | f x y -> b+++++-- | Every instance of this class should have an instance of 'HEqBy'+class HEqByFn f++-- * Arity++type Arity f n = (ArityFwd f n, ArityRev f n)++-- | calculate the number of arguments a function can take+class ArityFwd (f :: *) (n :: HNat) | f -> n+++-- | given the number of arguments a function can take, make sure+-- the function type actually matches+class ArityRev (f :: *) (n :: HNat) -- n -> f -- if we had -XDysfunctionalDependencies++instance ArityRev f HZero+instance (xf ~ (x -> f), ArityRev f n) => ArityRev xf (HSucc n)++ -- --------------------------------------------------------------------------  -- * Staged equality@@ -451,50 +654,178 @@ --  * Establish remaining value-level equality dynamically -- -- removed: use typeable-{- -class HStagedEq x y- where-  hStagedEq :: x -> y -> Bool--} +-- --------------------------------------------------------------------------+-- * Type-safe cast -- no longer need. We use a a ~ b -{-++-- * Cast++-- | Named after 'Data.Typeable.cast', which behaves the same at runtime.+-- One difference is that there is a HCast instance for every type, while+-- 'Typeable' instances can be missing sometimes.++class HCast x y where+    hCast :: x -> Maybe y++instance (HEq x y b, HCast1 b x y) => HCast x y where+    hCast = hCast1 (Proxy :: Proxy b)++-- | helper for 'HCast'+class HCast1 (b :: Bool) x y where+    hCast1 :: Proxy b -> x -> Maybe y++instance (x ~ y) => HCast1 True x y where+    hCast1 _ x = Just x++instance HCast1 False x y where+    hCast1 _ _ = Nothing++++ -- -------------------------------------------------------------------------- --- | A predicate for type equality+-- * Error messages++{- | 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:++> (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 ----- There are different implementations: see TypeEq*.hs+-- GHC.TypeLits.:<>: and GHC.TypeLits.:$$: are re-exported+type ErrText x = GHC.TypeLits.Text x+type ErrShowType x = GHC.TypeLits.ShowType x -class HBool b => TypeEq x y b | x y -> b+-- 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 --- Rely on lazy show for type-level Booleans-typeEq :: TypeEq t t' b => t -> t' -> b-typeEq = undefined+-- ** 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 --- A more disciplined version: based on proxies-proxyEq :: TypeEq t t' b => Proxy t -> Proxy t' -> b-proxyEq _ _ = undefined+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+type TypeablePolyK (a :: k) = Typeable a+#endif++-- * Constraining Lists+-- ** Length++-- | Ensure two lists have the same length. We do case analysis on the+-- first one (hence the type must be known to the type checker).+-- In contrast, the second list may be a type variable.+class SameLength' (es1 :: [k]) (es2 :: [m])+instance (es2 ~ '[]) => SameLength' '[] es2+instance (SameLength' xs ys, es2 ~ (y ': ys)) => SameLength' (x ': xs) es2++{- | symmetrical version of 'SameLength''. Written as a class instead of++ > type SameLength a b = (SameLength' a b, SameLength' b a)++since ghc expands type synonyms, but not classes (and it seems to have the same+result)+ -}+class (SameLength' x y, SameLength' y x) =>+        SameLength (x :: [k]) (y :: [m]) where --- ----------------------------------------------------------------------------- * Type-safe cast -- no longer need. We use a a ~ b+  {- | @SameLength x y => Equality (r x) (q y) (r x) (q y)@ -{--class TypeCast x y | x -> y, y -> x- where-  typeCast :: x -> y+  used like 'Control.Lens.simple', except it restricts+  the type-level lists involved to have the same length,+  without fixing the type of container or the elements+  in the list.+  -}+  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+++instance (SameLength' x y, SameLength' y x) => SameLength x y++type family SameLengths (xs :: [[k]]) :: Constraint+type instance SameLengths (x ': y ': ys) = (SameLength x y, SameLengths (y ': ys))+type instance SameLengths '[] = ()+type instance SameLengths '[x] = ()++-- ** Labels++class SameLabels (x :: k) (y :: m)++{- | @sameLabels@ constrains the type of an optic, such that the labels+   (@t@ in @Tagged t a@) are the same. @x@ or @y@ may have more elements+   than the other, in which case the elements at the end+   of the longer list do not have their labels constrained.++   see also 'sameLength' -}+sameLabels :: SameLabels x y => p (r x) (f (q y)) -> p (r x) (f (q y))+sameLabels = id +-- instances for [*] kind+instance SameLabels '[] '[]+instance SameLabels '[] (x ': xs)+instance SameLabels (x ': xs) '[]+instance (SameLabels x y, SameLabels xs ys) =>+  SameLabels (x ': xs) (y ': ys) --- -------------------------------------------------------------------------- --- * Error messages+instance (Label t ~ Label t') => SameLabels (Label t) (Tagged t' a)+instance (Label t ~ Label t') => SameLabels (Label t) (Label t')+instance (Label t ~ Label t') => SameLabels (Label t) (t' :: Symbol) --- | A class without instances for explicit failure-class Fail x+instance SameLabels (Label t) s => SameLabels (t :: Symbol) s+instance SameLabels (Label t) s => SameLabels (Tagged t a) s +-- ** A list has only Tagged values +-- | The 'Record', 'Variant', 'TIP', 'TIC' type constructors only make+-- sense when they are applied to an instance of this class+class HAllTaggedLV (ps :: [*])+instance HAllTaggedLV '[]+instance (HAllTaggedLV xs, x ~ Tagged t v) => HAllTaggedLV (x ': xs)+++-- | see Data.HList.Record.'zipTagged'+type family ZipTagged (ts :: [k]) (vs :: [*]) :: [*]+type instance ZipTagged (Label t ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs+type instance ZipTagged ((t :: Symbol) ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs+type instance ZipTagged '[] '[] = '[]
Data/HList/HArray.hs view
@@ -47,19 +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 (HNatIndexTooLarge n HList l0) => HUpdateAtHNat' n e1 '[] l0 where+  type HUpdateAtHNatR n e1 '[] = '[]+  hUpdateAtHNat' _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances"  -- -------------------------------------------------------------------------- -- * Projection@@ -70,7 +78,7 @@  newtype FHLookupByHNat (l :: [*]) = FHLookupByHNat (HList l) -instance HLookupByHNat n l => +instance HLookupByHNat n l =>     Apply (FHLookupByHNat l) (Proxy (n :: HNat)) where   type ApplyR (FHLookupByHNat l) (Proxy n) = HLookupByHNatR n l   apply (FHLookupByHNat l) n               = hLookupByHNat  n l@@ -80,7 +88,7 @@ -- repeated traversals of the HList l at run-time.  -- Here is a more optimal version with a better separation of--- compile-time and run-time computation. +-- compile-time and run-time computation. -- The list of labels to project is type-level only. -- We treat this list of labels as a set -- that is, we will -- ignore duplicates.@@ -90,11 +98,11 @@ -- We unify hProjectByHNats and hProjectAwayByHNats in one -- function, distinguished by the sel :: Bool in -- FHUProj below. The operation hProjectByHNats corresponds--- to sel = True (that is, elements of l whose indices are found in +-- to sel = True (that is, elements of l whose indices are found in -- ns are to be included in the result), whereas hProjectByHNats -- corresponds to set = False. -hProjectByHNats (_ :: Proxy (ns :: [HNat])) l = +hProjectByHNats (_ :: Proxy (ns :: [HNat])) l =     hUnfold (FHUProj :: FHUProj True ns) (l,hZero)  data FHUProj (sel :: Bool) (ns :: [HNat]) = FHUProj@@ -103,25 +111,25 @@     type ApplyR (FHUProj sel ns) (HList '[],n) = HNothing     apply _ _ = HNothing -instance (ch ~ Proxy (HBoolEQ sel (KMember n ns)), -	  Apply (ch, FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat))) =>+instance (ch ~ Proxy (HBoolEQ sel (KMember n ns)),+          Apply (ch, FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat))) =>     Apply (FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat)) where-    type ApplyR (FHUProj sel ns) (HList (e ': l),Proxy n) = +    type ApplyR (FHUProj sel ns) (HList (e ': l),Proxy n) =        ApplyR (Proxy (HBoolEQ sel (KMember n ns)), FHUProj sel ns)-	      (HList (e ': l),Proxy n)-    apply fn s = apply (undefined::ch,fn) s+              (HList (e ': l),Proxy n)+    apply fn s = apply (Proxy::ch,fn) s -instance Apply (Proxy True, FHUProj sel ns) +instance Apply (Proxy True, FHUProj sel ns)                (HList (e ': l),Proxy (n::HNat)) where-    type ApplyR (Proxy True, FHUProj sel ns) (HList (e ': l),Proxy n) = -	(HJust (e, (HList l,Proxy (HSucc n))))+    type ApplyR (Proxy True, FHUProj sel ns) (HList (e ': l),Proxy n) =+        (HJust (e, (HList l,Proxy (HSucc n))))     apply _ (HCons e l,n) = (HJust (e,(l,hSucc n)))  instance (Apply (FHUProj sel ns) (HList l, Proxy (HSucc n))) =>-    Apply (Proxy False, FHUProj sel ns) +    Apply (Proxy False, FHUProj sel ns)           (HList (e ': l),Proxy (n::HNat)) where-    type ApplyR (Proxy False, FHUProj sel ns) (HList (e ': l),Proxy n) = -	ApplyR (FHUProj sel ns) (HList l, Proxy (HSucc n))+    type ApplyR (Proxy False, FHUProj sel ns) (HList (e ': l),Proxy n) =+        ApplyR (FHUProj sel ns) (HList l, Proxy (HSucc n))     apply (_,fn) (HCons _ l,n) = apply fn (l,hSucc n)  @@ -131,13 +139,14 @@ type instance KMember n (n1 ': l) = HOr (HNatEq n n1) (KMember n l)  -- Useful abbreviations for complex types (which are inferred)-type HProjectByHNatsR (ns :: [HNat]) (l :: [*]) = +type HProjectByHNatsR (ns :: [HNat]) (l :: [*]) =     HUnfold (FHUProj True ns) (HList l, Proxy 'HZero)  type HProjectByHNatsCtx ns l =   (Apply (FHUProj True ns) (HList l, Proxy 'HZero),-      HUnfold' (FHUProj True ns) -       (ApplyR (FHUProj True ns) (HList l, Proxy 'HZero)))+      HUnfold' (FHUProj True ns)+       (HList l, Proxy 'HZero)+    )  -- * Complement of Projection @@ -146,20 +155,20 @@ -- Instead, we compute the complement of indices to project away -- to obtain the indices to project to, and then use hProjectByHNats. -- Only the latter requires run-time computation. The rest--- are done at compile-time only. +-- are done at compile-time only. -hProjectAwayByHNats (_ :: Proxy (ns :: [HNat])) l = +hProjectAwayByHNats (_ :: Proxy (ns :: [HNat])) l =     hUnfold (FHUProj :: FHUProj False ns) (l,hZero)   -- Useful abbreviations for complex types (which are inferred)-type HProjectAwayByHNatsR (ns :: [HNat]) (l :: [*]) = +type HProjectAwayByHNatsR (ns :: [HNat]) (l :: [*]) =     HUnfold (FHUProj False ns) (HList l, Proxy 'HZero)  type HProjectAwayByHNatsCtx ns l =   (Apply (FHUProj False ns) (HList l, Proxy 'HZero),-      HUnfold' (FHUProj False ns) (ApplyR (FHUProj False ns) -				   (HList l, Proxy 'HZero)))+      HUnfold' (FHUProj False ns) (HList l, Proxy 'HZero)+  )  -- * Splitting -- | Splitting an array according to indices@@ -167,7 +176,7 @@ -- The following is not optimal; we'll optimize later if needed  hSplitByHNats ns l = (hProjectByHNats ns l,-		      hProjectAwayByHNats ns l)+                      hProjectAwayByHNats ns l) {- hSplitByHNats ns l = hSplitByHNats' ns (hFlag l)
+ Data/HList/HCurry.hs view
@@ -0,0 +1,72 @@+{- |++ Description : curry / uncurry++ Convert between functions taking HLists and functions taking many arguments++-}+module Data.HList.HCurry where++import Data.HList.FakePrelude+import Data.HList.HList+import Data.HList.TypeEqO () -- Arity instance++{- | 'curry'/'uncurry' for many arguments and HLists instead of tuples++XXX the last FD @xs -> n@ is needed to make hCompose infer the right types:+arguably it shouldn't be needed++-}+class HLengthEq xs n => HCurry' (n :: HNat) f xs r+          | f xs -> r, r xs -> f, n f -> xs, xs -> n where+    hUncurry' :: Proxy n -> f -> HList xs -> r+    hCurry' :: Proxy n -> (HList xs -> r) -> f++instance HCurry' HZero b '[] b where+    hUncurry' _ b _ = b+    hCurry' _ f = f HNil++instance (HCurry' n b xs r) => HCurry' (HSucc n) (x -> b) (x ': xs) r where+    hUncurry' n f (HCons x xs) = hUncurry' (hPred n) (f x) xs+    hCurry' n f x = hCurry' (hPred n) (f . HCons x)++hUncurry f = hUncurry' (arityOf f) f++-- | Note: with ghc-7.10 the Arity constraint added here does not work+-- properly with hCompose, so it is possible that other uses of 'hCurry'+-- are better served by @hCurry' Proxy@.+hCurry f = let f' = hCurry' (arityOf f') f+           in f'++{- | compose two functions that take multiple arguments. The result of the+second function is the first argument to the first function. An example is+probably clearer:++>>> let f = hCompose (,,) (,)+>>> :t f+f :: ... -> ... -> ... -> ... -> ((..., ...), ..., ...)++>>> f 1 2 3 4+((1,2),3,4)++Note: polymorphism can make it confusing as to how many parameters a function+actually takes. For example, the first two ids are @id :: (a -> b) -> (a -> b)@ in++>>> (.) id id id 'y'+'y'++>>> hCompose id id id 'y'+'y'++still typechecks, but in that case @hCompose i1 i2 i3 x == i1 ((i2 i3) x)@+has id with different types than @(.) i1 i2 i3 x == (i1 (i2 i3)) x++Prompted by <http://stackoverflow.com/questions/28932054/can-hlistelim-be-composed-with-another-function>++-}+hCompose f g = hCurry' Proxy $ \xs -> case hSplitAt Proxy xs of+        (xg,xf) -> hUncurry f (hUncurry g xg `HCons` xf)+++arityOf :: Arity f n => f -> Proxy n+arityOf _ = Proxy
Data/HList/HList.hs view
@@ -1,1037 +1,1657 @@-{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   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--import Data.HList.FakePrelude-import Data.HList.HListPrelude--import Control.Applicative (Applicative, liftA2, pure)----- ----------------------------------------------------------------------------- * Heterogeneous type sequences--- $note------ The easiest way to ensure that sequences can only be formed with Nil--- and Cons is to use GADTs--- The kind [*] is list kind (lists lifted to types)--data HList (l::[*]) where-    HNil  :: HList '[]-    HCons :: e -> HList l -> HList (e ': l)---- | this comparison is two traversals-instance (ConvHList l, Eq (Prime l)) => Eq (HList l) where-    x == y = prime x == prime y---- ** Alternative representation-{- $note--HNil' and HCons' are the older ADT-style. This has some advantages-over the GADT:--* lazy pattern matches are allowed--* type inference is better if you want to directly pattern match-<http://stackoverflow.com/questions/19077037/is-there-any-deeper-type-theoretic-reason-ghc-cant-infer-this-type see stackoverflow post here>---}-data HNil' = HNil' deriving (Eq)-data HCons' a b = HCons' a b deriving (Eq)----- | conversion between GADT ('HList') and ADT ('HNil'' 'HCons'')--- representations-class (UnPrime (Prime a) ~ a) => ConvHList (a :: [*]) where-    type Prime a :: *-    type UnPrime b :: [*]-    prime :: HList a -> Prime a-    unPrime :: Prime a -> HList a--instance ConvHList as => ConvHList (a ': as) where-    type Prime   (a ': as) = a `HCons'` Prime as-    type UnPrime (b `HCons'` bs) = (b ': UnPrime bs)-    prime (a `HCons` as) = a `HCons'` prime as-    unPrime ~(a `HCons'` as) = a `HCons` unPrime as--instance ConvHList '[] where-    type Prime '[] = HNil'-    type UnPrime HNil' = '[]-    prime _ = HNil'-    unPrime _ = HNil-----instance Show (HList '[]) where-    show _ = "H[]"--instance (Show e, Show (HList l)) => Show (HList (e ': l)) where-    show (HCons x l) = let 'H':'[':s = show l-		       in "H[" ++ show x ++ -			          (if s == "]" then s else ", " ++ s)--infixr 2 `HCons`----- ----------------------------------------------------------------------------- * Basic list functions---- | 'head'-hHead :: HList (e ': l) -> e-hHead (HCons x _) = x---- | 'tail'-hTail :: HList (e ': l) -> HList l-hTail (HCons _ l) = l---- | Length-type family HLength (x :: [k]) :: HNat-type instance HLength '[] = HZero-type instance HLength (x ': xs) = HSucc (HLength xs)--hLength   :: HList l -> Proxy (HLength l)-hLength _ =  undefined---- ** Append-instance HExtend e (HList l) where-  type HExtendR e (HList l) = HList (e ': l)-  (.*.) = HCons--instance HAppend (HList l1) (HList l2) where-  hAppend = hAppendList-type instance HAppendR (HList l1) (HList l2) = HList (HAppendList l1 l2)--type family HAppendList (l1 :: [k]) (l2 :: [k]) :: [k]-type instance HAppendList '[] l = l-type instance HAppendList (e ': l) l' = e ': HAppendList l l'---- | the same as 'hAppend'-hAppendList :: HList l1 -> HList l2 -> HList (HAppendList l1 l2)-hAppendList HNil l = l-hAppendList (HCons x l) l' = HCons x (hAppend l l')---- ------------------------------------------------------------------------------ ** Alternative append----- | 'hAppend'' below is implemented using the same idea-append' :: [a] -> [a] -> [a]-append' l l' = foldr (:) l' l---- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr'-hAppend' :: (HFoldr FHCons v l r) => HList l -> v -> r-hAppend' l l' = hFoldr FHCons l' l--data FHCons = FHCons--instance ( x ~ (e,HList l), y ~ (HList (e ': l))) => ApplyAB FHCons x y  where-    applyAB _ (e,l) = HCons e l----- ** Historical append--{- $--The original HList code is included below. In both cases-we had to program the algorithm twice, at the term and the type levels.--[@The class HAppend@]--> class HAppend l l' l'' | l l' -> l''->  where->   hAppend :: l -> l' -> l''->--[@The instance following the normal append@]--> instance HList l => HAppend HNil l l->  where->   hAppend HNil l = l->-> instance (HList l, HAppend l l' l'')->       => HAppend (HCons x l) l' (HCons x l'')->  where->   hAppend (HCons x l) l' = HCons x (hAppend l l')---}---- ----------------------------------------------------------------------------- * Reversing HLists---- Append the reversed l1 to l2-type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]-type instance HRevApp '[] l = l-type instance HRevApp (e ': l) l' = HRevApp l (e ': l')--hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)-hRevApp HNil l = l-hRevApp (HCons x l) l' = hRevApp l (HCons x l')--hReverse l = hRevApp l HNil------ --------------------------------------------------------------------------------- * A nicer notation for lists-------- | List termination-hEnd :: HList l -> HList l-hEnd = id--{- ^-   Note:--        [@x :: HList a@] means: @forall a. x :: HList a@--        [@hEnd x@] means: @exists a. x :: HList a@--}----- |  Building lists--hBuild :: (HBuild' '[] r) => r-hBuild =  hBuild' HNil--class HBuild' l r where-    hBuild' :: HList l -> r--instance (l' ~ HRevApp l '[])-      => HBuild' l (HList l') where-  hBuild' l = hReverse l--instance HBuild' (a ': l) r-      => HBuild' l (a->r) where-  hBuild' l x = hBuild' (HCons x l)---- ** examples-{- $examplesNote--The classes above allow the third (shortest) way to make a list-(containing a,b,c) in this case--> list = a `HCons` b `HCons` c `HCons` HNil-> list = a .*. b .*. c .*. HNil-> list = hEnd $ hBuild a b c-->>> let x = hBuild True in hEnd x-H[True]-->>> let x = hBuild True 'a' in hEnd x-H[True, 'a']-->>> let x = hBuild True 'a' "ok" in hEnd x-H[True, 'a', "ok"]---}---- *** historical-{- $hbuild the show instance has since changed, but these uses of-'hBuild'/'hEnd' still work--> HList> let x = hBuild True in hEnd x-> HCons True HNil--> HList> let x = hBuild True 'a' in hEnd x-> HCons True (HCons 'a' HNil)--> HList> let x = hBuild True 'a' "ok" in hEnd x-> HCons True (HCons 'a' (HCons "ok" HNil))--> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5))-> HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))--> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus-> True---}---- ------------------------------------------------------------------------------ * folds--- ** foldr--- $foldNote  Consume a heterogenous list. GADTs and type-classes mix well---class HFoldr f v (l :: [*]) r where-    hFoldr :: f -> v -> HList l -> r--instance (v ~ v') => HFoldr f v '[] v' where-    hFoldr       _ v _   = v---- | uses 'ApplyAB' not 'Apply'-instance (ApplyAB f (e, r) r', HFoldr f v l r)-    => HFoldr f v (e ': l) r' where-    hFoldr f v (HCons x l)    = applyAB f (x, hFoldr f v l :: r)---class HScanr f z ls rs where-    hScanr :: f -> z -> HList ls -> HList rs--instance HScanr f z '[] '[z] where-    hScanr _ z _ = HCons z HNil--instance (ApplyAB f (x,r) s, HScanr f z xs (r ': rs)) => HScanr f z (x ': xs) (s ': r ': rs) where-    hScanr f z (HCons x xs) =-        case hScanr f z xs :: HList (r ': rs) of-            HCons r rs -> (applyAB f (x,r) :: s) `HCons` r `HCons` rs--class HFoldr1 f (l :: [*]) r where-    hFoldr1 :: f -> HList l -> r--instance (v ~ v') => HFoldr1 f '[v] v' where-    hFoldr1      _ (HCons v _)  = v---- | uses 'ApplyAB' not 'Apply'-instance (ApplyAB f (e, r) r', HFoldr1 f (e' ': l) r)-    => HFoldr1 f (e ': e' ': l) r' where-    hFoldr1 f (HCons x l)    = applyAB f (x, hFoldr1 f l :: r)----- ** foldl--{- | like 'foldl'--->>> hFoldl (uncurry $ flip (:)) [] (1 `HCons` 2 `HCons` HNil)-[2,1]----}-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)-    => HFoldl f z (x ': xs) r where-    hFoldl f z (x `HCons` xs) = hFoldl f (applyAB f (z,x) :: z') xs--instance (z ~ z') => HFoldl f z '[] z' where-    hFoldl _ z _ = z-------- * unfold--- $unfoldNote Produce a heterogenous list. Uses the more limited--- 'Apply' instead of 'App' since that's all that is needed for uses of this--- function downstream. Those could in principle be re-written.--hUnfold :: (Apply p s, HUnfold' p (ApplyR p s)) => p -> s -> HList (HUnfold p s)-hUnfold p s = hUnfold' p (apply p s)--type HUnfold p s = HUnfoldR p (ApplyR p s)--class HUnfold' p res where-    type HUnfoldR p res :: [*]-    hUnfold' :: p -> res -> HList (HUnfoldR p res)--instance HUnfold' p HNothing where-    type HUnfoldR p HNothing = '[]-    hUnfold' _ _ = HNil--instance (Apply p s, HUnfold' p (ApplyR p s)) => HUnfold' p (HJust (e,s)) where-    type HUnfoldR p (HJust (e,s)) = e ': HUnfold p s-    hUnfold' p (HJust (e,s)) = HCons e (hUnfold p s)----- * replicate--class (HLength (HReplicateR n e) ~ n) =>-      HReplicate (n :: HNat) e where-    hReplicate :: Proxy n -> e -> HList (HReplicateR n e)--instance HReplicate HZero e where-    hReplicate _ _ = HNil--instance HReplicate n e => HReplicate (HSucc n) e where-    hReplicate n e = e `HCons` hReplicate (hPred n) e---- | would be associated with 'HReplicate' except we want--- it to work with `e` of any kind, not just `*` that you can--- put into a HList. An \"inverse\" of 'HLength'-type family HReplicateR (n :: HNat) (e :: k) :: [k]-type instance HReplicateR HZero e = '[]-type instance HReplicateR (HSucc n) e = e ': HReplicateR n e---- * concat--{- |--Like 'concat' but for HLists of HLists.--Works in ghci... puzzling as what is different in doctest (it isn't-@-XExtendedDefaultRules@)--> hConcat $ hBuild (hBuild 1 2 3) (hBuild 'a' "abc")--H[1, 2, 3, 'a', "abc"]----}-class HConcat (a :: [*]) where-    type HConcatR a :: [*]-    hConcat :: HList a -> HList (HConcatR a)--instance HConcat '[] where-    type HConcatR '[] = '[]-    hConcat _ = HNil--instance (x ~ HList t, HConcat xs) => HConcat (x ': xs) where-    type HConcatR (x ': xs) = HAppendList (UnHList x) (HConcatR xs)-    hConcat (x `HCons` xs) = x `hAppendList` hConcat xs---type family UnHList a :: [*]-type instance UnHList (HList a) = a---- ----------------------------------------------------------------------------- * traversing HLists---- ** producing HList--- *** map--- $mapNote It could be implemented with 'hFoldr', as we show further below--{- | hMap is written such that the length of the result list-can be determined from the length of the argument list (and-the other way around). Similarly, the type of the elements-of the list is propagated in both directions too.--Excuse the ugly types printed. Unfortunately ghc (still?)-shows types like @'[a,b]@ using the actual constructors involved-@(':) a ((':) b '[])@ (or even worse when the kind variables are printed).-->>> :set -XNoMonomorphismRestriction->>> let xs = 1 .*. 'c' .*. HNil->>> :t hMap (HJust ()) xs-hMap (HJust ()) xs-  :: Num y => HList ((':) * (HJust y) ((':) * (HJust Char) ('[] *)))---These 4 examples show that the constraint on the length (2 in this cae)-can be applied before or after the 'hMap'. That inference is independent of the-direction that type information is propagated for the individual elements.--->>> let asLen2 xs = xs `asTypeOf` (undefined :: HList '[a,b])-->>> let lr xs = asLen2 (applyAB (HMap HRead) xs)->>> let ls xs = asLen2 (applyAB (HMap HShow) xs)->>> let rl xs = applyAB (HMap HRead) (asLen2 xs)->>> let sl xs = applyAB (HMap HShow) (asLen2 xs)--->>> :t lr-lr-  :: (Read y, Read y1) =>-     HList ((':) * String ((':) * String ('[] *)))-     -> HList ((':) * y ((':) * y1 ('[] *)))-->>> :t rl-rl-  :: (Read y, Read y1) =>-     HList ((':) * String ((':) * String ('[] *)))-     -> HList ((':) * y ((':) * y1 ('[] *)))--->>> :t ls-ls-  :: (Show y, Show y1) =>-     HList ((':) * y ((':) * y1 ('[] *)))-     -> HList ((':) * String ((':) * String ('[] *)))-->>> :t sl-sl-  :: (Show y, Show y1) =>-     HList ((':) * y ((':) * y1 ('[] *)))-     -> HList ((':) * String ((':) * String ('[] *)))---}--hMap f xs = applyAB (HMap f) xs--newtype HMap f = HMap f--instance (HMapCxt f as bs as' bs') => ApplyAB (HMap f) as bs where-    applyAB (HMap f) = hMapAux f--type HMapCxt f as bs as' bs' = (HMapAux f as' bs', as ~ HList as', bs ~ HList bs',-    SameLength as' bs')----- | Ensure two lists have the same length. We do case analysis on the--- first one (hence the type must be known to the type checker).--- In contrast, the second list may be a type variable.-class SameLength' (es1 :: [k]) (es2 :: [m])-instance (es2 ~ '[]) => SameLength' '[] es2-instance (SameLength' xs ys, es2 ~ (y ': ys)) => SameLength' (x ': xs) es2--{- | symmetrical version of 'SameLength''. Written as a class instead of-- > type SameLength a b = (SameLength' a b, SameLength' b a)--since ghc expands type synonyms, but not classes (and it seems to have the same-result)---}-class (SameLength' x y, SameLength' y x) =>-        SameLength (x :: [k]) (y :: [m])-instance (SameLength' x y, SameLength' y x) => SameLength x y----class HMapAux f (l :: [*]) (r :: [*]) where-  hMapAux :: SameLength l r => f -> HList l -> HList r--instance HMapAux f '[] '[] where-  hMapAux       _  _  = HNil--instance (ApplyAB f e e', HMapAux f l l', SameLength l l')-    => HMapAux f (e ': l) (e' ': l') where-  hMapAux f (HCons x l)    = applyAB f x `HCons` hMapAux f l------- ------------------------------------------------------------------------------ **** alternative implementation--- $note currently broken--newtype MapCar f = MapCar f---- | Same as 'hMap' only a different implementation.-hMapMapCar :: (HFoldr (MapCar f) (HList '[]) l l') =>-    f -> HList l -> l'-hMapMapCar f = hFoldr (MapCar f) HNil--instance ApplyAB f e e' => ApplyAB (MapCar f) (e,HList l) (HList (e' ': l)) where-    applyAB (MapCar f) (e,l) = HCons (applyAB f e) l----- ------------------------------------------------------------------------------ *** @appEndo . mconcat . map Endo@-{- |-->>> let xs = length .*. (+1) .*. (*2) .*. HNil->>> hComposeList xs "abc"-8----}-hComposeList-  :: (HFoldr Comp (a -> a) l (t -> a)) => HList l -> t -> a-hComposeList fs v0 = let r = hFoldr (undefined :: Comp) (\x -> x `asTypeOf` r) fs v0 in r----- ------------------------------------------------------------------------------ *** sequence-{- |-   A heterogeneous version of--   > sequenceA :: (Applicative m) => [m a] -> m [a]--   Only now we operate on heterogeneous lists, where different elements-   may have different types 'a'.-   In the argument list of monadic values (m a_i),-   although a_i may differ, the monad 'm' must be the same for all-   elements. That's why we needed "Data.HList.TypeCastGeneric2" (currently (~)).-   The typechecker will complain-   if we attempt to use hSequence on a HList of monadic values with different-   monads.--   The 'hSequence' problem was posed by Matthias Fischmann-   in his message on the Haskell-Cafe list on Oct 8, 2006--   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018708.html>--   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018784.html>- -}--class (Applicative m, SameLength a b) => HSequence m a b | a -> b, m b -> a where-    hSequence :: HList a -> m (HList b)-{- ^--[@Maybe@]-->>> hSequence $ Just (1 :: Integer) `HCons` (Just 'c') `HCons` HNil-Just H[1, 'c']-->>> hSequence $  return 1 `HCons` Just  'c' `HCons` HNil-Just H[1, 'c']---[@List@]-->>> hSequence $ [1] `HCons` ['c'] `HCons` HNil-[H[1, 'c']]----}--instance Applicative m => HSequence m '[] '[] where-    hSequence _ = pure HNil--instance (m1 ~ m, Applicative m, HSequence m as bs) =>-    HSequence m (m1 a ': as) (a ': bs) where-    hSequence (HCons a b) = liftA2 HCons a (hSequence b)---- data ConsM = ConsM--- consM = LiftA2 FHCons-newtype LiftA2 f = LiftA2 f--instance (ApplyAB f (x,y) z, mz ~ m z, mxy ~ (m x, m y), Applicative m) => ApplyAB (LiftA2 f) mxy mz where-    applyAB (LiftA2 f) xy = liftA2 (curry (applyAB f)) `uncurry` xy--{--instance (m1 ~ m, Applicative m) => ApplyAB ConsM (m a, m1 (HList l)) (m (HList (a ': l)))  where-{--    type ApplyB ConsM (m a, m1 (HList l)) = Just (m (HList (a ': l)))-    type ApplyA ConsM (m (HList (a ': l))) = Just (m a, m (HList l))-    -}-    applyAB _ (me,ml) = liftA2 HCons me ml-    -}----- **** alternative implementation---- | 'hSequence2' is not recommended over 'hSequence' since it possibly doesn't--- allow inferring argument types from the result types. Otherwise this version--- should do exactly the same thing.------ The DataKinds version needs a little help to find the type of the--- return HNil, unlike the original version, which worked just fine as------  > hSequence l = hFoldr ConsM (return HNil) l---{--hSequence2 :: HSequence2 l f a => HList l -> f a-hSequence2 l =-    let rHNil = pure HNil `asTypeOf` (liftA undefined x)-        x = hFoldr ConsM rHNil l-    in x----- | abbreviation for the constraint on 'hSequence2'-type HSequence2 l f a = (Applicative f, HFoldr ConsM (f (HList ('[]))) l (f a))--}----- ------------------------------------------------------------------------------- ----------------------------------------------------------------------------- ** producing homogenous lists---- *** map (no sequencing)--- $mapOut This one we implement via hFoldr--newtype Mapcar f = Mapcar f--instance (l ~ [e'], ApplyAB f e e', el ~ (e,l)) => ApplyAB (Mapcar f) el l where-    applyAB (Mapcar f) (e, l) = applyAB f e : l---- A synonym for the complex constraint-type HMapOut f l e = (HFoldr (Mapcar f) [e] l [e])--hMapOut :: forall f e l. HMapOut f l e => f -> HList l -> [e]-hMapOut f l = hFoldr (Mapcar f) ([] :: [e]) l----- ----------------------------------------------------------------------------- *** mapM---- |------ > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b]------ Likewise for mapM_.------ See 'hSequence' if the result list should also be heterogenous.--hMapM   :: (Monad m, HMapOut f l (m e)) => f -> HList l -> [m e]-hMapM f =  hMapOut f---- | GHC doesn't like its own type.--- hMapM_  :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m ()--- Without explicit type signature, it's Ok. Sigh.--- Anyway, Hugs does insist on a better type. So we restrict as follows:----hMapM_   :: (Monad m, HMapOut f l (m ())) => f -> HList l -> m ()-hMapM_ f =  sequence_ .  disambiguate . hMapM f- where-  disambiguate :: [q ()] -> [q ()]-  disambiguate =  id-------- ----------------------------------------------------------------------------- * Type-level equality for lists ('HEq')--instance HEq '[] '[]      True-instance HEq '[] (e ': l) False-instance HEq (e ': l) '[] False-instance (HEq e1 e2 b1, HEq l1 l2 b2, br ~ HAnd b1 b2)-      => HEq (e1 ': l1) (e2 ': l2) br---- ----------------------------------------------------------------------------- * Ensure a list to contain HNats only--- | We do so constructively, converting the HList whose elements--- are Proxy HNat to [HNat]. The latter kind is unpopulated and--- is present only at the type level.--type family HNats (l :: [*]) :: [HNat]-type instance HNats '[] = '[]-type instance HNats (Proxy n ': l) = n ': HNats l--hNats :: HList l -> Proxy (HNats l)-hNats = undefined----- ----------------------------------------------------------------------------- * Membership tests---- | Check to see if an HList contains an element with a given type--- This is a type-level only test--class HMember (e1 :: k) (l :: [k]) (b :: Bool) | e1 l -> b-instance HMember e1 '[] False-instance (HEq e1 e b, HMember' b e1 l br) => HMember  e1 (e ': l) br-class HMember' (b0 :: Bool) (e1 :: k) (l :: [k]) (b :: Bool) | b0 e1 l -> b-instance HMember' True e1 l True-instance (HMember e1 l br) => HMember' False e1 l br---- The following is a similar type-only membership test--- It uses the user-supplied curried type equality predicate pred-type family HMemberP pred e1 (l :: [*]) :: Bool-type instance HMemberP pred e1 '[] = False---type instance HMemberP pred e1 (e ': l) = HMemberP' pred e1 l (ApplyR pred (e1,e))--type family HMemberP' pred e1 (l :: [*]) pb :: Bool-type instance HMemberP' pred e1 l (Proxy True) = True-type instance HMemberP' pred e1 l (Proxy False) = HMemberP pred e1 l- --hMember :: HMember e l b => Proxy e -> Proxy l -> Proxy b-hMember = undefined---- ** Another type-level membership test------ | Check to see if an element e occurs in a list l--- If not, return 'Nothing--- If the element does occur, return 'Just l1--- where l1 is a type-level list without e-class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r-instance HMemberM e1 '[] 'Nothing-instance (HEq e1 e b, HMemberM1 b e1 (e ': l) res)-      =>  HMemberM e1 (e ': l) res--class HMemberM1 (b::Bool) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r-instance HMemberM1 True e1 (e ': l) ('Just l)-instance (HMemberM e1 l r, HMemberM2 r e1 (e ': l) res)-    => HMemberM1 False e1 (e ': l) res--class HMemberM2 (b::Maybe [k]) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r-instance HMemberM2 Nothing e1 l Nothing-instance HMemberM2 (Just l1) e1 (e ': l) (Just (e ': l1))---- ------------------------------------------------------------------------------ * Staged equality for lists--- $note removed. use Typeable instead--{--instance HStagedEq (HList '[]) (HList '[])- where-  hStagedEq _ _ = True--instance HStagedEq (HList '[]) (HList (e ': l))- where-  hStagedEq _ _ = False--instance HStagedEq (HList (e ': l)) (HList '[])- where-  hStagedEq _ _ = False--instance ( HEq e e' b-         , HStagedEq (HList l) (HList l')-         , HStagedEq' b e e'-         )-      =>   HStagedEq (HList (e ': l)) (HList (e' ': l'))- where-  hStagedEq (HCons e l) (HCons e' l') = (hStagedEq' b e e') && b'-   where-    b  = proxy :: Proxy b-    b' = hStagedEq l l'--class HStagedEq' (b :: Bool) e e'- where-  hStagedEq' :: Proxy b -> e -> e' -> Bool--instance HStagedEq' False e e'- where-  hStagedEq' _ _ _ = False--instance Eq e => HStagedEq' True e e- where-  hStagedEq' _ = (==)--}--{------- * Static set property based on HEq-class HSet l-instance HSet HNil-instance (HMember e l HFalse, HSet l) => HSet (HCons e l)--}---- * Find an element in a set based on HEq--- | It is a pure type-level operation-class HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n--instance (HEq e1 e2 b, HFind' b e1 l n) => HFind e1 (e2 ': l) n--class HFind' (b::Bool) (e :: k) (l::[k]) (n::HNat) | b e l -> n-instance HFind' True e l HZero-instance HFind e l n => HFind' False e l (HSucc n)------ ** Membership test based on type equality---- | could be an associated type if HEq had one-class HTMember e (l :: [*]) (b :: Bool) | e l -> b-instance HTMember e '[] False-instance (HEq e e' b, HTMember e l b', HOr b b' ~ b'')-      =>  HTMember e (e' ': l) b''--hTMember :: HTMember e l b => e -> HList l -> Proxy b-hTMember _ _ = Proxy----- * Intersection based on HTMember--class HTIntersect l1 l2 l3 | l1 l2 -> l3- where-  -- | Like 'Data.List.intersect'-  hTIntersect :: HList l1 -> HList l2 -> HList l3--instance HTIntersect '[] l '[]- where-  hTIntersect _ _ = HNil--instance ( HTMember h l1 b-         , HTIntersectBool b h t l1 l2-         )-         => HTIntersect (h ': t) l1 l2- where-  hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1-   where-    b = hTMember h l1--class HTIntersectBool (b :: Bool) h t l1 l2 | b h t l1 -> l2- where- hTIntersectBool :: Proxy b -> h -> HList t -> HList l1 -> HList l2--instance HTIntersect t l1 l2-      => HTIntersectBool True h t l1 (h ': l2)- where-  hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1)--instance HTIntersect t l1 l2-      => HTIntersectBool False h t l1 l2- where-  hTIntersectBool _ _ t l1 = hTIntersect t l1----- * Turn a heterogeneous list into a homogeneous one---- | Same as @hMapOut Id@-class HList2List l e- where-  hList2List :: HList l -> [e]--instance HList2List '[] e- where-  hList2List HNil = []--instance HList2List l e-      => HList2List (e ': l) e- where-  hList2List (HCons e l) = e:hList2List l------- ----------------------------------------------------------------------------- * With 'HMaybe'---- ** Turn list in a list of justs--- | the same as @map Just@------ >>> toHJust (2 .*. 'a' .*. HNil)--- H[HJust 2, HJust 'a']------ >>> toHJust2 (2 .*. 'a' .*. HNil)--- H[HJust 2, HJust 'a']--class ToHJust l l' | l -> l', l' -> l- where-  toHJust :: HList l -> HList l'--instance ToHJust '[] '[]- where-  toHJust HNil = HNil--instance ToHJust l l' => ToHJust (e ': l) (HJust e ': l')- where-  toHJust (HCons e l) = HCons (HJust e) (toHJust l)---- | alternative implementation. The Apply instance is in "Data.HList.FakePrelude".--- A longer type could be inferred.--- toHJust2 :: (HMap' (HJust ()) a b) => HList a -> HList b-toHJust2 xs = hMap (HJust ()) xs---- ----------------------------------------------------------------------------- ** Extract justs from list of maybes------ >>> let xs = 2 .*. 'a' .*. HNil--- >>> fromHJust (toHJust xs) == xs--- True--class FromHJust l- where-  type FromHJustR l :: [*]-  fromHJust :: HList l -> HList (FromHJustR l)--instance FromHJust '[]- where-  type FromHJustR '[] = '[]-  fromHJust HNil = HNil--instance FromHJust l => FromHJust (HNothing ': l)- where-  type FromHJustR (HNothing ': l) = FromHJustR l-  fromHJust (HCons _ l) = fromHJust l--instance FromHJust l => FromHJust (HJust e ': l)- where-  type FromHJustR (HJust e ': l) = e ': FromHJustR l-  fromHJust (HCons (HJust e) l) = HCons e (fromHJust l)---- *** alternative implementation---- | A longer type could be inferred.--- fromHJust2 :: (HMap' HFromJust a b) => HList a -> HList b-fromHJust2 xs = hMap HFromJust xs--data HFromJust = HFromJust-instance (hJustA ~ HJust a) => ApplyAB HFromJust hJustA a where-    applyAB _ (HJust a) = a----- ----------------------------------------------------------------------------- * Annotated lists--data HAddTag t = HAddTag t-data HRmTag    = HRmTag---- hAddTag :: HMap' (HAddTag t) l r => t -> HList l -> HList r-hAddTag t l = hMap (HAddTag t) l---- hRmTag ::  HMap HRmTag l => HList l -> HList (HMapR HRmTag l)-hRmTag l    = hMap HRmTag l--instance (et ~ (e,t)) => ApplyAB (HAddTag t) e et- where-  applyAB (HAddTag t) e = (e,t)---instance (e' ~ e) => ApplyAB HRmTag (e,t) e'- where-  applyAB _ (e,_) = e----- | Annotate list with a type-level Boolean--- hFlag :: HMap' (HAddTag (Proxy True)) l r => HList l -> HList r-hFlag l = hAddTag hTrue l----- ----------------------------------------------------------------------------- * Splitting by HTrue and HFalse---- | Analogus to Data.List.'Data.List.partition' 'snd'------ >>> hSplit $ (2,hTrue) .*. (3,hTrue) .*. (1,hFalse) .*. HNil--- (H[2, 3],H[1])------ it might make more sense to instead have @LVPair Bool e@--- instead of @(e, Proxy Bool)@ since the former has the same--- runtime representation as @e@--class HSplit l- where-  type HSplitT l :: [*]-  type HSplitF l :: [*]-  hSplit :: HList l -> (HList (HSplitT l), HList (HSplitF l))--instance HSplit '[]- where-  type HSplitT '[] = '[]-  type HSplitF '[] = '[]-  hSplit HNil = (HNil,HNil)--instance HSplit l => HSplit ((e, Proxy True) ': l)- where--  type HSplitT ((e,Proxy True) ': l) = e ': HSplitT l-  type HSplitF ((e,Proxy True) ': l) = HSplitF l--  hSplit (HCons (e,_) l) = (HCons e l',l'')-   where-    (l',l'') = hSplit l--instance HSplit l => HSplit ((e,Proxy False) ': l)- where-  type HSplitT ((e,Proxy False) ': l) = HSplitT l-  type HSplitF ((e,Proxy False) ': l) = e ': HSplitF l--  hSplit (HCons (e,_) l) = (l',HCons e l'')-   where-    (l',l'') = hSplit l--{---Let expansion makes a difference to Hugs:--HListPrelude> let x = (hFlag (HCons "1" HNil)) in hSplit x-(HCons "1" HNil,HNil)-HListPrelude> hSplit (hFlag (HCons "1" HNil))-ERROR - Unresolved overloading-*** Type       : HSplit (HCons ([Char],HTrue) HNil) a b => (a,b)-*** Expression : hSplit (hFlag (HCons "1" HNil))----}+{-# LANGUAGE CPP #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Basic declarations for typeful heterogeneous lists.++ -}++module Data.HList.HList where++import Data.HList.FakePrelude+import Data.HList.HListPrelude++import Text.ParserCombinators.ReadP+import Data.List++import LensDefs++import Data.Array (Ix)++#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup+#endif++-- --------------------------------------------------------------------------+-- * Heterogeneous type sequences+{- $note++There are three sensible ways to define HLists:++@+data HList (l::[*]) where+    HNil  :: HList '[]+    HCons :: e -> HList l -> HList (e ': l)+@++This ensures that sequences can only be formed with Nil+and Cons. The argument to HList is a promoted lists (kind @[*]@),+which has a more attractive syntax.+++Earlier versions of HList used an algebraic data type:++@+data HCons a b = HCons a b+data HNil = HNil+@++Disadvantages:++* values with types like @HCons Int Double@ to be created,+  which are nonsense to the functions in HList++* some recursive functions do not need a class with the GADT. For example:++  @+    hInit :: HListGADT (x ': xs) -> HListGADT (HInit (x ': xs))+    hInit (HCons x xs@(HCons _ _)) = HCons x (hInit xs)+    hInit (HCons _ HNil) = HNil++    type family HInit (xs :: [k]) :: [k]+  @++  but without the GADT, 'hInit' is written as in a class,+  which complicates inferred types+++Advantages++* lazy pattern matches are allowed, so lazy pattern matching+  on a value @undefined :: HList [a,b,c]@ can create the+  spine of the list. 'hProxies' avoids the use of 'undefined',+  but a slightly more complicated class context has to be written+  or inferred.++* type inference is better if you want to directly pattern match+<http://stackoverflow.com/questions/19077037/is-there-any-deeper-type-theoretic-reason-ghc-cant-infer-this-type see stackoverflow post here>++* better pattern exhaustiveness checking (as of ghc-7.8)++* standalone deriving works++* Data.Coerce.coerce works because the parameters have role representational,+  not nominal as they are for the GADT and data family. Probably the GADT/type+  family actually do have a representational role:+  <http://stackoverflow.com/questions/24222552/does-this-gadt-actually-have-type-role-representational>++++The data family version (currently used) gives the same type constructor+@HList :: [*] -> *@ as the GADT, while pattern matching behaves+like the algebraic data type. Furthermore, nonsense values like+@HCons 1 2 :: HCons Int Int@ cannot be written with the data family.++A variation on the data family version is++> data instance HList '[] = HNil+> newtype instance HList (x ': xs) = HCons1 (x, HList xs)+> pattern HCons x xs = HCons1 (x, xs)++This allows HList to have a nominal role, but on the other+hand the PatternSynonym is not supported with ghc-7.6 and+exhaustiveness checking is not as good (warnings for _ being+unmatched)++-}+++data family HList (l::[*])++data instance HList '[] = HNil+data instance HList (x ': xs) = x `HCons` HList xs++deriving instance Eq (HList '[])+deriving instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs))++deriving instance Ord (HList '[])+deriving instance (Ord x, Ord (HList xs)) => Ord (HList (x ': xs))++deriving instance Ix (HList '[])+deriving instance (Ix x, Ix (HList xs)) => Ix (HList (x ': xs))++deriving instance Bounded (HList '[])+deriving instance (Bounded x, Bounded (HList xs)) => Bounded (HList (x ': xs))+++-- Enum cannot be derived+++-- | creates a HList of Proxies++class HProxiesFD (xs :: [*]) pxs | pxs -> xs -- DropProxy pxs ~ xs+                      , xs -> pxs -- AddProxy xs ~ pxs+      where hProxies :: HList pxs++{- Ideally we could write:++> class DropProxy (AddProxy xs) ~ xs => HProxies xs where+>     hProxies :: HList (AddProxy xs)++See https://ghc.haskell.org/trac/ghc/ticket/10009 -}+type HProxies xs = HProxiesFD xs (AddProxy xs)+++{- | Add 'Proxy' to a type++>>> let x = undefined :: HList (AddProxy [Char,Int])+>>> :t x+x :: HList '[Proxy Char, Proxy Int]+++-}+type family AddProxy (xs :: k) :: k+type instance AddProxy '[] = '[]+type instance AddProxy (x ': xs) = AddProxy x ': AddProxy xs+type instance AddProxy (x :: *) = Proxy x++-- | inverse of 'AddProxy'+type family DropProxy (xs :: k) :: k+type instance DropProxy (x ': xs) = DropProxy x ': DropProxy xs+type instance DropProxy '[] = '[]+type instance DropProxy (Proxy x) = x++instance HProxiesFD '[] '[] where+    hProxies = HNil++instance (HProxiesFD xs pxs) => HProxiesFD (x ': xs) (Proxy x ': pxs) where+    hProxies = Proxy `HCons` hProxies++++instance Show (HList '[]) where+    show _ = "H[]"++instance (Show e, Show (HList l)) => Show (HList (e ': l)) where+    show (HCons x l) =+      case show l of+        'H':'[':s -> "H[" ++ show x ++ (if s == "]" then s else "," ++ s)+        s -> error $ "unreachable branch: " ++ show x ++ " " ++ s++instance Read (HList '[]) where+    readsPrec _ str = case stripPrefix "H[]" str of+                        Nothing -> []+                        Just rest -> [(HNil, rest)]++instance+   (HProxies l, Read e,+    HSequence ReadP (ReadP e ': readP_l) (e ': l),+    HMapCxt HList ReadElement (AddProxy l) readP_l)  =>+      Read (HList (e ': l)) where+  readsPrec _ = readP_to_S $ do+    _ <- string "H["+    l <- return (hProxies :: HList (AddProxy l))+    let parsers = readS_to_P reads `HCons` hMap ReadElement l+    hlist <- hSequence parsers+    _ <- string "]"+    return hlist+++-- similar to ReadComponent used to define instance Read Record+data ReadElement = ReadElement++instance (y ~ ReadP x, Read x) => ApplyAB ReadElement (Proxy x) y where+    applyAB ReadElement _ = do+      _ <- string ","+      readS_to_P reads+++infixr 2 `HCons`+++-- --------------------------------------------------------------------------+-- * Basic list functions++-- | 'head'+hHead :: HList (e ': l) -> e+hHead (HCons x _) = x++-- | 'tail'+hTail :: HList (e ': l) -> HList l+hTail (HCons _ l) = l++-- | 'last'+hLast xs = hHead (hReverse_ xs)+++class HInit xs where+    type HInitR xs :: [*]+    hInit :: HList xs -> HList (HInitR xs)++instance HInit '[x] where+    type HInitR '[x] = '[]+    hInit _ = HNil++instance HInit (b ': c) => HInit (a ': b ': c) where+    type HInitR (a ': b ': c) = a ': HInitR (b ': c)+    hInit (a `HCons` bc) = a `HCons` hInit bc+++-- | Length, but see 'HLengthEq' instead+type family HLength (x :: [k]) :: HNat+type instance HLength '[] = HZero+type instance HLength (x ': xs) = HSucc (HLength xs)++hLength   :: HLengthEq l n => HList l -> Proxy n+hLength _ =  Proxy++-- ** Append+instance HExtend e (HList l) where+  type HExtendR e (HList l) = HList (e ': l)+  (.*.) = HCons++instance HAppendList l1 l2 => HAppend (HList l1) (HList l2) where+  hAppend = hAppendList+type instance HAppendR (HList l1) (HList l2) = HList (HAppendListR l1 l2)++type family HAppendListR (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HAppendListR '[] l = l+type instance HAppendListR (e ': l) l' = e ': HAppendListR l l'+++class HAppendList l1 l2 where+  -- | the same as 'hAppend'+  hAppendList :: HList l1 -> HList l2 -> HList (HAppendListR l1 l2)++instance HAppendList '[] l2 where+  hAppendList HNil l = l++instance HAppendList l l' => HAppendList (x ': l) l' where+  hAppendList (HCons x l) l' = HCons x (hAppendList l l')++-- --------------------------------------------------------------------------++-- ** Alternative append+++-- | 'hAppend'' below is implemented using the same idea+append' :: [a] -> [a] -> [a]+append' l l' = foldr (:) l' l++-- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr'+hAppend' :: (HFoldr FHCons v l r) => HList l -> v -> r+hAppend' l l' = hFoldr FHCons l' l++data FHCons = FHCons++instance ( x ~ (e,HList l), y ~ (HList (e ': l))) => ApplyAB FHCons x y  where+    applyAB _ (e,l) = HCons e l+++-- ** Historical append++{- $++The original HList code is included below. In both cases+we had to program the algorithm twice, at the term and the type levels.++[@The class HAppend@]++> class HAppend l l' l'' | l l' -> l''+>  where+>   hAppend :: l -> l' -> l''+>++[@The instance following the normal append@]++> instance HList l => HAppend HNil l l+>  where+>   hAppend HNil l = l+>+> instance (HList l, HAppend l l' l'')+>       => HAppend (HCons x l) l' (HCons x l'')+>  where+>   hAppend (HCons x l) l' = HCons x (hAppend l l')++-}++-- --------------------------------------------------------------------------+-- * Reversing HLists++-- Append the reversed l1 to l2+type family HRevAppR (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HRevAppR '[] l = l+type instance HRevAppR (e ': l) l' = HRevAppR l (e ': l')+++class HRevApp l1 l2 l3 | l1 l2 -> l3 where+    hRevApp :: HList l1 -> HList l2 -> HList l3++instance HRevApp '[] l2 l2 where+    hRevApp _ l = l++instance HRevApp l (x ': l') z => HRevApp (x ': l) l' z where+    hRevApp (HCons x l) l' = hRevApp l (HCons x l')++++class HReverse xs sx | xs -> sx, sx -> xs where+    hReverse :: HList xs -> HList sx++instance (HRevApp xs '[] sx,+          HRevApp sx '[] xs) => HReverse xs sx where+    hReverse l = hRevApp l HNil++-- | a version of 'hReverse' that does not allow the type+-- information to flow backwards+hReverse_ l = hRevApp l HNil++-- --------------------------------------------------------------------------++--+-- * A nicer notation for lists+--+++-- | List termination+hEnd :: HList l -> HList l+hEnd = id++{- ^+   Note:++        [@x :: HList a@] means: @forall a. x :: HList a@++        [@hEnd x@] means: @exists a. x :: HList a@+-}+++-- |  Building lists++hBuild :: (HBuild' '[] r) => r+hBuild =  hBuild' HNil++class HBuild' l r where+    hBuild' :: HList l -> r++instance HReverse l l'+      => HBuild' l (HList l') where+  hBuild' l = hReverse l++instance HBuild' (a ': l) r+      => HBuild' l (a->r) where+  hBuild' l x = hBuild' (HCons x l)++-- ** examples+{- $examplesNote++The classes above allow the third (shortest) way to make a list+(containing a,b,c) in this case++> list = a `HCons` b `HCons` c `HCons` HNil+> list = a .*. b .*. c .*. HNil+> list = hEnd $ hBuild a b c++>>> let x = hBuild True in hEnd x+H[True]++>>> let x = hBuild True 'a' in hEnd x+H[True,'a']++>>> let x = hBuild True 'a' "ok" in hEnd x+H[True,'a',"ok"]++hBuild can also produce a Record, such that++> hBuild x y ^. from unlabeled++can also be produced using++@+'hEndR' $ hBuild x y+@++-}++-- *** historical+{- $hbuild the show instance has since changed, but these uses of+'hBuild'/'hEnd' still work++> HList> let x = hBuild True in hEnd x+> HCons True HNil++> HList> let x = hBuild True 'a' in hEnd x+> HCons True (HCons 'a' HNil)++> HList> let x = hBuild True 'a' "ok" in hEnd x+> HCons True (HCons 'a' (HCons "ok" HNil))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5))+> HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus+> True++-}++-- --------------------------------------------------------------------------++-- * folds+-- ** foldr+-- $foldNote  Consume a heterogenous list.+++class HFoldr f v (l :: [*]) r where+    hFoldr :: f -> v -> HList l -> r++instance (v ~ v') => HFoldr f v '[] v' where+    hFoldr       _ v _   = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr f v l r)+    => HFoldr f v (e ': l) r' where+    hFoldr f v (HCons x l)    = applyAB f (x, hFoldr f v l :: r)+++class HScanr f z ls rs where+    hScanr :: f -> z -> HList ls -> HList rs++instance lz ~ '[z] => HScanr f z '[] lz where+    hScanr _ z _ = HCons z HNil++instance (ApplyAB f (x,r) s, HScanr f z xs (r ': rs),+          srrs ~ (s ': r ': rs)) => HScanr f z (x ': xs) srrs where+    hScanr f z (HCons x xs) =+        case hScanr f z xs :: HList (r ': rs) of+            HCons r rs -> (applyAB f (x,r) :: s) `HCons` r `HCons` rs++class HFoldr1 f (l :: [*]) r where+    hFoldr1 :: f -> HList l -> r++instance (v ~ v') => HFoldr1 f '[v] v' where+    hFoldr1      _ (HCons v _)  = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr1 f (e' ': l) r)+    => HFoldr1 f (e ': e' ': l) r' where+    hFoldr1 f (HCons x l)    = applyAB f (x, hFoldr1 f l :: r)+++-- ** foldl++{- | like 'foldl'+++>>> hFoldl (uncurry $ flip (:)) [] (1 `HCons` 2 `HCons` HNil)+[2,1]+++-}+class HFoldl f (z :: *) xs (r :: *) where+    hFoldl :: f -> z -> HList 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++instance (z ~ z') => HFoldl f z '[] z' where+    hFoldl _ z _ = z++++++-- * unfolds++-- ** unfold+-- $unfoldNote Produce a heterogenous list. Uses the more limited+-- 'Apply' instead of 'App' since that's all that is needed for uses of this+-- function downstream. Those could in principle be re-written.++-- hUnfold :: (Apply p s, HUnfold' p s) => p -> s -> HList (HUnfold p s)+hUnfold p s = hUnfold' p (apply p s)++type HUnfold p s = HUnfoldR p (ApplyR p s)++type family HUnfoldR p res :: [*]+type instance HUnfoldR p HNothing = '[]+type instance HUnfoldR p (HJust (e,s)) = e ': HUnfoldR p (ApplyR p s)++type HUnfold' p res = HUnfoldFD p (ApplyR p res) (HUnfold p res)++class HUnfoldFD p res z | p res -> z where+    hUnfold' :: p -> res -> HList z++instance HUnfoldFD p HNothing '[] where+    hUnfold' _ _ = HNil++instance (Apply p s, HUnfoldFD p (ApplyR p s) z) => HUnfoldFD p (HJust (e,s)) (e ': z) where+    hUnfold' p (HJust (e,s)) = HCons e (hUnfold p s)+++-- ** replicate++{- |++Sometimes the result type can fix the type of the+first argument:++>>> hReplicate Proxy () :: HList '[ (), (), () ]+H[(),(),()]++However, with HReplicate all elements must have the same type, so it may be+easier to use 'HList2List':++>>> list2HList (repeat 3) :: Maybe (HList [Int, Int, Int])+Just H[3,3,3]++-}+class HLengthEq es n => HReplicateFD (n :: HNat) e es+          | n e -> es, es -> n where+    hReplicate :: Proxy n -> e -> HList es++instance HReplicateFD HZero e '[] where+    hReplicate _ _ = HNil++instance (HReplicateFD n e es, e ~ e') => HReplicateFD (HSucc n) e (e' ': es) where+    hReplicate n e = e `HCons` hReplicate (hPred n) e++type HReplicate n e = HReplicateFD n e (HReplicateR n e)++-- | would be associated with 'HReplicate' except we want+-- it to work with `e` of any kind, not just `*` that you can+-- put into a HList. An \"inverse\" of 'HLength'+type family HReplicateR (n :: HNat) (e :: k) :: [k]+type instance HReplicateR HZero e = '[]+type instance HReplicateR (HSucc n) e = e ': HReplicateR n e++{- | HReplicate produces lists that can be converted to ordinary+lists++>>> let two = hSucc (hSucc hZero)+>>> let f = Fun' fromInteger :: Fun' Num Integer++>>> :t applyAB f+applyAB f :: Num b => Integer -> b++>>> hReplicateF two f 3+H[3,3]++>>> hReplicateF Proxy f 3 :: HList [Int, Double, Integer]+H[3,3.0,3]++-}+class HLengthEq r n => HReplicateF (n :: HNat) f z r | r -> n where+    hReplicateF :: HLengthEq r n => Proxy n -> f -> z -> HList r++instance HReplicateF HZero f z '[] where+    hReplicateF _ _ _ = HNil++instance (ApplyAB f z fz,+          HReplicateF n f z r')+  => HReplicateF (HSucc n) f z (fz ': r') where+    hReplicateF n f z = applyAB f z `HCons` hReplicateF (hPred n) f z++-- ** iterate+{- |++This function behaves like 'iterate', with an extra+argument to help figure out the result length++>>> let three = hSucc (hSucc (hSucc hZero))+>>> let f = Fun Just :: Fun '() Maybe++>>> :t applyAB f+applyAB f :: a -> Maybe a++f is applied to different types:++>>> hIterate three f ()+H[(),Just (),Just (Just ())]++It is also possible to specify the length later on,+as done with Prelude.'iterate'++>>> let take3 x | _ <- hLength x `asTypeOf` three = x+>>> take3 $ hIterate Proxy f ()+H[(),Just (),Just (Just ())]++-}+class HLengthEq r n => HIterate n f z r where+    hIterate :: HLengthEq r n => Proxy n -> f -> z -> HList r++instance HIterate HZero f z '[] where+    hIterate _ _ _ = HNil++instance (ApplyAB f z z',+      HIterate n f z' r',+      z ~ z_)+     => HIterate (HSucc n) f z (z_ ': r') where+    hIterate n f z = z `HCons` hIterate (hPred n) f (applyAB f z :: z')++-- * concat++{- |++Like 'concat' but for HLists of HLists.++Works in ghci... puzzling as what is different in doctest (it isn't+@-XExtendedDefaultRules@)++>>> let a = hEnd $ hBuild 1 2 3+>>> let b = hEnd $ hBuild 'a' "abc"+>>> hConcat $ hBuild a b+H[1,2,3,'a',"abc"]++-}+type HConcat xs = HConcatFD xs (HConcatR xs)++hConcat :: HConcat xs => HList xs -> HList (HConcatR xs)+hConcat x = hConcatFD x++type family HConcatR (a :: [*]) :: [*]+type instance HConcatR '[] = '[]+type instance HConcatR (x ': xs) = HAppendListR (UnHList x) (HConcatR xs)++type family UnHList a :: [*]+type instance UnHList (HList a) = a++-- for the benefit of ghc-7.10.1+class HConcatFD xxs xs | xxs -> xs+    where hConcatFD :: HList xxs -> HList xs++instance HConcatFD '[] '[] where+    hConcatFD _ = HNil++instance (HConcatFD as bs, HAppendFD a bs cs) => HConcatFD (HList a ': as) cs where+    hConcatFD (HCons x xs) = x `hAppendFD` hConcatFD xs++class HAppendFD a b ab | a b -> ab where+    hAppendFD :: HList a -> HList b -> HList ab++instance HAppendFD '[] b b where+    hAppendFD _ b = b++instance HAppendFD as bs cs => HAppendFD (a ': as) bs (a ': cs) where+    hAppendFD (HCons a as) bs = a `HCons` hAppendFD as bs+++-- --------------------------------------------------------------------------+-- * traversing HLists++-- ** producing HList+-- *** map+-- $mapNote It could be implemented with 'hFoldr', as we show further below++{- | hMap is written such that the length of the result list+can be determined from the length of the argument list (and+the other way around). Similarly, the type of the elements+of the list is propagated in both directions too.++>>> :set -XNoMonomorphismRestriction+>>> let xs = 1 .*. 'c' .*. HNil+>>> :t hMap (HJust ()) xs+hMap (HJust ()) xs :: Num y => HList '[HJust y, HJust Char]+++These 4 examples show that the constraint on the length (2 in this case)+can be applied before or after the 'hMap'. That inference is independent of the+direction that type information is propagated for the individual elements.+++>>> let asLen2 xs = xs `asTypeOf` (undefined :: HList '[a,b])++>>> let lr xs = asLen2 (applyAB (HMap HRead) xs)+>>> let ls xs = asLen2 (applyAB (HMap HShow) xs)+>>> let rl xs = applyAB (HMap HRead) (asLen2 xs)+>>> let sl xs = applyAB (HMap HShow) (asLen2 xs)+++>>> :t lr+lr+  :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...]++>>> :t rl+rl+  :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...]+++>>> :t ls+ls+  :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String]++>>> :t sl+sl+  :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String]++-}++newtype HMap f = HMap f++hMap f xs = applyAB (HMap f) xs++instance (HMapCxt r f a b, as ~ r a, bs ~ r b)+    => ApplyAB (HMap f) as bs where+    applyAB (HMap f) = hMapAux f+++-- | hMap constrained to HList+hMapL f xs = applyAB (HMapL f) xs++newtype HMapL f = HMapL f++instance (HMapCxt HList f a b, as ~ HList a, bs ~ HList b) => ApplyAB (HMapL f) as bs where+    applyAB (HMapL f) = hMapAux f+++class (SameLength a b, HMapAux r f a b) => HMapCxt r f a b++instance (SameLength a b, HMapAux r f a b) => HMapCxt r f a b++++class HMapAux (r :: [*] -> *) f (x :: [*]) (y :: [*]) where+  hMapAux :: SameLength x y => f -> r x -> r y++instance HMapAux HList f '[] '[] where+  hMapAux       _  _  = HNil++instance (ApplyAB f e e', HMapAux HList f l l', SameLength l l')+    => HMapAux HList f (e ': l) (e' ': l') where+  hMapAux f (HCons x l)    = applyAB f x `HCons` hMapAux f l+++++-- --------------------------------------------------------------------------++-- **** alternative implementation+-- $note currently broken++newtype MapCar f = MapCar f++-- | Same as 'hMap' only a different implementation.+hMapMapCar :: (HFoldr (MapCar f) (HList '[]) l l') =>+    f -> HList l -> l'+hMapMapCar f = hFoldr (MapCar f) HNil++instance ApplyAB f e e' => ApplyAB (MapCar f) (e,HList l) (HList (e' ': l)) where+    applyAB (MapCar f) (e,l) = HCons (applyAB f e) l+++-- --------------------------------------------------------------------------++-- *** @appEndo . mconcat . map Endo@+{- |++>>> let xs = length .*. (+1) .*. (*2) .*. HNil+>>> hComposeList xs "abc"+8+++-}+hComposeList+  :: (HFoldr Comp (a -> a) l (t -> a)) => HList l -> t -> a+hComposeList fs v0 = let r = hFoldr (Comp :: Comp) (\x -> x `asTypeOf` r) fs v0 in r+++-- --------------------------------------------------------------------------++-- *** sequence+{- |+   A heterogeneous version of++   > sequenceA :: (Applicative m) => [m a] -> m [a]++   Only now we operate on heterogeneous lists, where different elements+   may have different types 'a'.+   In the argument list of monadic values (m a_i),+   although a_i may differ, the monad 'm' must be the same for all+   elements. That's why we needed "Data.HList.TypeCastGeneric2" (currently (~)).+   The typechecker will complain+   if we attempt to use hSequence on a HList of monadic values with different+   monads.++   The 'hSequence' problem was posed by Matthias Fischmann+   in his message on the Haskell-Cafe list on Oct 8, 2006++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018708.html>++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018784.html>+ -}++class (Applicative m, SameLength a b) => HSequence m a b | a -> b, m b -> a where+    hSequence :: HList a -> m (HList b)+{- ^++[@Maybe@]++>>> hSequence $ Just (1 :: Integer) `HCons` (Just 'c') `HCons` HNil+Just H[1,'c']++>>> hSequence $  return 1 `HCons` Just  'c' `HCons` HNil+Just H[1,'c']+++[@List@]++>>> hSequence $ [1] `HCons` ['c'] `HCons` HNil+[H[1,'c']]+++-}++instance Applicative m => HSequence m '[] '[] where+    hSequence _ = pure HNil++instance (m1 ~ m, Applicative m, HSequence m as bs) =>+    HSequence m (m1 a ': as) (a ': bs) where+    hSequence (HCons a b) = liftA2 HCons a (hSequence b)++-- **** alternative implementation++-- | 'hSequence2' is not recommended over 'hSequence' since it possibly doesn't+-- allow inferring argument types from the result types. Otherwise this version+-- should do exactly the same thing.+--+-- The DataKinds version needs a little help to find the type of the+-- return HNil, unlike the original version, which worked just fine as+--+--  > hSequence l = hFoldr ConsM (return HNil) l++hSequence2 l =+    let rHNil = pure HNil `asTypeOf` (fmap undefined x)+        x = hFoldr (LiftA2 FHCons) rHNil l+    in x++++-- --------------------------------------------------------------------------+++-- --------------------------------------------------------------------------+-- ** producing homogenous lists++-- *** map (no sequencing)+-- $mapOut This one we implement via hFoldr++newtype Mapcar f = Mapcar f++instance (l ~ [e'], ApplyAB f e e', el ~ (e,l)) => ApplyAB (Mapcar f) el l where+    applyAB (Mapcar f) (e, l) = applyAB f e : l++-- A synonym for the complex constraint+type HMapOut f l e = (HFoldr (Mapcar f) [e] l [e])++-- | compare @hMapOut f@ with @'hList2List' . 'hMap' f@+hMapOut :: forall f e l. HMapOut f l e => f -> HList l -> [e]+hMapOut f l = hFoldr (Mapcar f) ([] :: [e]) l+++-- --------------------------------------------------------------------------+-- *** mapM++-- |+--+-- > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b]+--+-- Likewise for 'mapM_'.+--+-- See 'hSequence' if the result list should also be heterogenous.++hMapM   :: (Monad m, HMapOut f l (m e)) => f -> HList l -> [m e]+hMapM f =  hMapOut f++-- | GHC doesn't like its own type.+--+-- > hMapM_ :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m ()+--+-- Without explicit type signature, it's Ok. Sigh.+-- Anyway, Hugs does insist on a better type. So we restrict as follows:+--+hMapM_   :: (Monad m, HMapOut f l (m ())) => f -> HList l -> m ()+hMapM_ f =  sequence_ .  disambiguate . hMapM f+ where+  disambiguate :: [q ()] -> [q ()]+  disambiguate =  id++++++-- --------------------------------------------------------------------------+-- * Ensure a list to contain HNats only+-- | We do so constructively, converting the HList whose elements+-- are Proxy HNat to [HNat]. The latter kind is unpopulated and+-- is present only at the type level.++type family HNats (l :: [*]) :: [HNat]+type instance HNats '[] = '[]+type instance HNats (Proxy n ': l) = n ': HNats l++hNats :: HList l -> Proxy (HNats l)+hNats _ = Proxy+++-- --------------------------------------------------------------------------+-- * Membership tests++-- | Check to see if an HList contains an element with a given type+-- This is a type-level only test++class HMember (e1 :: k) (l :: [k]) (b :: Bool) | e1 l -> b+instance HMember e1 '[] False+instance (HEq e1 e b, HMember' b e1 l br) => HMember  e1 (e ': l) br+class HMember' (b0 :: Bool) (e1 :: k) (l :: [k]) (b :: Bool) | b0 e1 l -> b+instance HMember' True e1 l True+instance (HMember e1 l br) => HMember' False e1 l br++-- | The following is a similar type-only membership test+-- It uses the user-supplied curried type equality predicate pred+type family HMemberP pred e1 (l :: [*]) :: Bool+type instance HMemberP pred e1 '[] = False+type instance HMemberP pred e1 (e ': l) = HMemberP' pred e1 l (ApplyR pred (e1,e))++type family HMemberP' pred e1 (l :: [*]) pb :: Bool+type instance HMemberP' pred e1 l (Proxy True) = True+type instance HMemberP' pred e1 l (Proxy False) = HMemberP pred e1 l+++hMember :: HMember e l b => Proxy e -> Proxy l -> Proxy b+hMember _ _ = Proxy++-- ** Another type-level membership test+--+-- | Check to see if an element e occurs in a list l+-- If not, return 'Nothing+-- If the element does occur, return 'Just l1+-- where l1 is a type-level list without e+class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r+instance HMemberM e1 '[] 'Nothing+instance (HEq e1 e b, HMemberM1 b e1 (e ': l) res)+      =>  HMemberM e1 (e ': l) res++class HMemberM1 (b::Bool) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM1 True e1 (e ': l) ('Just l)+instance (HMemberM e1 l r, HMemberM2 r e1 (e ': l) res)+    => HMemberM1 False e1 (e ': l) res++class HMemberM2 (b::Maybe [k]) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM2 Nothing e1 l Nothing+instance HMemberM2 (Just l1) e1 (e ': l) (Just (e ': l1))++-- --------------------------------------------------------------------------++-- * Staged equality for lists+-- $note removed. use Typeable instead+++{-+-- * Static set property based on HEq+class HSet l+instance HSet HNil+instance (HMember e l HFalse, HSet l) => HSet (HCons e l)+-}++-- * Find an element in a set based on HEq+-- | It is a pure type-level operation+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]) (l0 :: [k]) (n :: HNat) | e l -> n++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]) (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)++++-- ** Membership test based on type equality++-- | could be an associated type if HEq had one+class HTMember e (l :: [*]) (b :: Bool) | e l -> b+instance HTMember e '[] False+instance (HEq e e' b, HTMember e l b', HOr b b' ~ b'')+      =>  HTMember e (e' ': l) b''++hTMember :: HTMember e l b => e -> HList l -> Proxy b+hTMember _ _ = Proxy+++-- * Intersection based on HTMember++class HTIntersect l1 l2 l3 | l1 l2 -> l3+ where+  -- | Like 'Data.List.intersect'+  hTIntersect :: HList l1 -> HList l2 -> HList l3++instance HTIntersect '[] l '[]+ where+  hTIntersect _ _ = HNil++instance ( HTMember h l1 b+         , HTIntersectBool b h t l1 l2+         )+         => HTIntersect (h ': t) l1 l2+ where+  hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1+   where+    b = hTMember h l1++class HTIntersectBool (b :: Bool) h t l1 l2 | b h t l1 -> l2+ where+ hTIntersectBool :: Proxy b -> h -> HList t -> HList l1 -> HList l2++instance HTIntersect t l1 l2+      => HTIntersectBool True h t l1 (h ': l2)+ where+  hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1)++instance HTIntersect t l1 l2+      => HTIntersectBool False h t l1 l2+ where+  hTIntersectBool _ _ t l1 = hTIntersect t l1+++-- * Convert between heterogeneous lists and homogeneous ones++-- | @hMapOut id@ is similar, except this function is restricted+-- to HLists that actually contain a value (so the list produced+-- will be nonempty). This restriction allows adding a functional+-- dependency, which means that less type annotations can be necessary.+class HList2List l e | l -> e+ where+  hList2List :: HList l -> [e]+  list2HListSuffix :: [e] -> Maybe (HList l, [e])+++list2HList :: HList2List l e => [e] -> Maybe (HList l)+list2HList = fmap fst . list2HListSuffix+++instance HList2List '[e] e+ where+  hList2List (HCons e HNil) = [e]++  list2HListSuffix (e : es) = Just (HCons e HNil, es)+  list2HListSuffix [] = Nothing+++instance HList2List (e' ': l) e+      => HList2List (e ': e' ': l) e+ where+  hList2List (HCons e l) = e:hList2List l++  list2HListSuffix (e : es) = (\(hl,rest) -> (HCons e hl, rest))+                                  <$> list2HListSuffix es+  list2HListSuffix [] = Nothing++-- | @Prism [s] [t] (HList s) (HList t)@+listAsHList x = prism hList2List (\l -> case list2HListSuffix l of+                                 Just (hl,[])  -> Right hl+                                 _ -> Left []) x++-- | @Prism' [a] (HList s)@+--+-- where @s ~ HReplicateR n a@+listAsHList' x = isSimple listAsHList x+++-- --------------------------------------------------------------------------+-- * With 'HMaybe'++-- ** Turn list in a list of justs+-- | the same as @map Just@+--+-- >>> toHJust (2 .*. 'a' .*. HNil)+-- H[HJust 2,HJust 'a']+--+-- >>> toHJust2 (2 .*. 'a' .*. HNil)+-- H[HJust 2,HJust 'a']++class FromHJustR (ToHJustR l) ~ l => ToHJust l+ where+  type ToHJustR l :: [*]+  toHJust :: HList l -> HList (ToHJustR l)++instance ToHJust '[]+ where+  type ToHJustR '[] = '[]+  toHJust HNil = HNil++instance ToHJust l => ToHJust (e ': l)+ where+  type ToHJustR (e ': l) = HJust e ': ToHJustR l+  toHJust (HCons e l) = HCons (HJust e) (toHJust l)++-- | alternative implementation. The Apply instance is in "Data.HList.FakePrelude".+-- A longer type could be inferred.+toHJust2 :: (HMapCxt r (HJust ()) a b,+             ToHJust a, b ~ ToHJustR a -- added to get equivalent inference+             ) => r a -> r b+toHJust2 xs = hMap (HJust ()) xs++-- --------------------------------------------------------------------------+-- ** Extract justs from list of maybes+--+-- >>> let xs = 2 .*. 'a' .*. HNil+-- >>> fromHJust (toHJust xs) == xs+-- True++class (FromHJustR (ToHJustR l) ~ l) => FromHJust l+ where+  type FromHJustR l :: [*]+  fromHJust :: HList l -> HList (FromHJustR l)++instance FromHJust '[]+ where+  type FromHJustR '[] = '[]+  fromHJust HNil = HNil++instance FromHJust l => FromHJust (HNothing ': l)+ where+  type FromHJustR (HNothing ': l) = FromHJustR l+  fromHJust (HCons _ l) = fromHJust l++instance FromHJust l => FromHJust (HJust e ': l)+ where+  type FromHJustR (HJust e ': l) = e ': FromHJustR l+  fromHJust (HCons (HJust e) l) = HCons e (fromHJust l)++-- *** alternative implementation++-- | This implementation is shorter.+fromHJust2 :: (HMapCxt r HFromJust a b) => r a -> r b+fromHJust2 xs = hMap HFromJust xs++data HFromJust = HFromJust+instance (hJustA ~ HJust a) => ApplyAB HFromJust hJustA a where+    applyAB _ (HJust a) = a+++-- --------------------------------------------------------------------------+-- * Annotated lists++data HAddTag t = HAddTag t+data HRmTag    = HRmTag++-- hAddTag :: HMapCxt (HAddTag t) l r => t -> HList l -> HList r+hAddTag t l = hMap (HAddTag t) l++-- hRmTag ::  HMapCxt HRmTag l => HList l -> HList (HMapR HRmTag l)+hRmTag l    = hMap HRmTag l++instance (et ~ (e,t)) => ApplyAB (HAddTag t) e et+ where+  applyAB (HAddTag t) e = (e,t)+++instance (e' ~ e) => ApplyAB HRmTag (e,t) e'+ where+  applyAB _ (e,_) = e+++-- | Annotate list with a type-level Boolean+--+-- > hFlag :: HMapCxt (HAddTag (Proxy True)) l r => HList l -> HList r+hFlag l = hAddTag hTrue l+++-- --------------------------------------------------------------------------+-- * Splitting by HTrue and HFalse++-- | Analogus to Data.List.'Data.List.partition' 'snd'. See also 'HPartition'+--+-- >>> let (.=.) :: p x -> y -> Tagged x y; _ .=. y = Tagged y+-- >>> hSplit $ hTrue .=. 2 .*. hTrue .=. 3 .*. hFalse .=. 1 .*. HNil+-- (H[2,3],H[1])+--+-- it might make more sense to instead have @LVPair Bool e@+-- instead of @(e, Proxy Bool)@ since the former has the same+-- runtime representation as @e@++class HSplit l+ where+  type HSplitT l :: [*]+  type HSplitF l :: [*]+  hSplit :: HList l -> (HList (HSplitT l), HList (HSplitF l))++instance HSplit '[]+ where+  type HSplitT '[] = '[]+  type HSplitF '[] = '[]+  hSplit HNil = (HNil,HNil)++instance HSplit l => HSplit ((e, Proxy True) ': l)+ where++  type HSplitT ((e,Proxy True) ': l) = e ': HSplitT l+  type HSplitF ((e,Proxy True) ': l) = HSplitF l++  hSplit (HCons (e,_) l) = (HCons e l',l'')+   where+    (l',l'') = hSplit l++instance HSplit l => HSplit ((e,Proxy False) ': l)+ where+  type HSplitT ((e,Proxy False) ': l) = HSplitT l+  type HSplitF ((e,Proxy False) ': l) = e ': HSplitF l++  hSplit (HCons (e,_) l) = (l',HCons e l'')+   where+    (l',l'') = hSplit l+++instance HSplit l => HSplit (Tagged True e ': l)+ where++  type HSplitT (Tagged True e ': l) = e ': HSplitT l+  type HSplitF (Tagged True e ': l) = HSplitF l++  hSplit (HCons (Tagged e) l) = (HCons e l',l'')+   where+    (l',l'') = hSplit l++instance HSplit l => HSplit (Tagged False e ': l)+ where+  type HSplitT (Tagged False e ': l) = HSplitT l+  type HSplitF (Tagged False e ': l) = e ': HSplitF l++  hSplit (HCons (Tagged e) l) = (l',HCons e l'')+   where+    (l',l'') = hSplit l+{-++Let expansion makes a difference to Hugs:++HListPrelude> let x = (hFlag (HCons "1" HNil)) in hSplit x+(HCons "1" HNil,HNil)+HListPrelude> hSplit (hFlag (HCons "1" HNil))+ERROR - Unresolved overloading+*** Type       : HSplit (HCons ([Char],HTrue) HNil) a b => (a,b)+*** Expression : hSplit (hFlag (HCons "1" HNil))+++-}++-- --------------------------------------------------------------------------+-- * Splitting by Length++{- | 'splitAt'++setup++>>> let two = hSucc (hSucc hZero)+>>> let xsys = hEnd $ hBuild 1 2 3 4++If a length is explicitly provided, the resulting lists are inferred++>>> hSplitAt two xsys+(H[1,2],H[3,4])++>>> let sameLength_ :: SameLength a b => r a -> r b -> r a; sameLength_ = const+>>> let len2 x = x `sameLength_` HCons () (HCons () HNil)++If the first chunk of the list (a) has to be a certain length, the type of the+Proxy argument can be inferred.++>>> case hSplitAt Proxy xsys of (a,b) -> (len2 a, b)+(H[1,2],H[3,4])++-}+class (HLengthEq xs n,+       HAppendList1 xs ys xsys+       )+      => HSplitAt (n :: HNat) xsys xs ys+                   | n xsys -> xs ys+                      , xs ys -> xsys+                      , xs -> n+                     where+    hSplitAt :: Proxy n -> HList xsys -> (HList xs, HList ys)++instance (HSplitAt1 '[] n xsys xs ys,+          HAppendList1 xs ys xsys,+          HLengthEq xs n) =>+    HSplitAt n xsys xs ys where+      hSplitAt n xsys = hSplitAt1 HNil n xsys++-- | helper for 'HSplitAt'+class HSplitAt1 accum (n :: HNat) xsys xs ys | accum n xsys -> xs ys where+    hSplitAt1 :: HList accum -> Proxy n -> HList xsys -> (HList xs, HList ys)++instance HRevApp accum '[] xs => HSplitAt1 accum HZero ys xs ys where+    hSplitAt1 xs _zero ys = (hReverse_ xs, ys)++instance HSplitAt1 (b ': accum) n bs xs ys+    => HSplitAt1 accum (HSucc n) (b ': bs) xs ys where+    hSplitAt1 accum n (HCons b bs) = hSplitAt1 (HCons b accum) (hPred n) bs++{- | a better way to write @HLength xs ~ n@ because:++1. it works properly with ghc-7.10 (probably another example of ghc bug #10009)++2. it works backwards a bit in that if @n@ is known, then @xs@ can be+   refined:++>>> undefined :: HLengthEq xs HZero => HList xs+H[]++-}+class (SameLength' (HReplicateR n ()) xs,+        HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq (xs :: [*]) (n :: HNat) | xs -> n++instance (SameLength' (HReplicateR n ()) xs,+          HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq xs n++class HLengthEq1 (xs :: [*]) n -- pick the instance based on n's constructor+instance (HLengthEq xs n, xxs ~ (x ': xs)) => HLengthEq1 xxs (HSucc n)+instance (xxs ~ '[]) => HLengthEq1 xxs HZero++class HLengthEq2 (xs :: [*]) n | xs -> n -- pick the instance based on xs' constructor+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@+--+-- used by 'HSplitAt'+class HStripPrefix xs xsys ys+      => HAppendList1 (xs :: [k]) (ys :: [k]) (xsys :: [k])+        | xs ys -> xsys,+          xs xsys -> ys+          -- , ys xsys -> xs+          -- hard to prove++instance HAppendList1 '[] ys ys+instance (HAppendList1 xs ys zs) => HAppendList1 (x ': xs) ys (x ': zs)+++-- | analog of 'Data.List.stripPrefix'+class HStripPrefix xs xsys ys | xs xsys -> ys+instance (x' ~ x, HStripPrefix xs xsys ys) => HStripPrefix (x' ': xs) (x ': xsys) ys+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+    -- | alternatively: @hUncurry (,,,)@+    hToTuple :: HList v -> t+    hFromTuple :: t -> HList v++-- | @Iso (HList v) (HList v') a b@+hTuple x = iso hToTuple hFromTuple x++-- | @Iso' (HList v) a@+hTuple' x = isSimple hTuple x++instance HTuple '[] () where+    hToTuple HNil = ()+    hFromTuple () = HNil++instance HTuple '[a,b] (a,b) where+    hToTuple (a `HCons` b `HCons` HNil) = (a,b)+    hFromTuple (a,b) = (a `HCons` b `HCons` HNil)++instance HTuple '[a,b,c] (a,b,c) where+    hToTuple (a `HCons` b `HCons` c `HCons` HNil) = (a,b,c)+    hFromTuple (a,b,c) = (a `HCons` b `HCons` c `HCons` HNil)++instance HTuple '[a,b,c,d] (a,b,c,d) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a,b,c,d)+    hFromTuple (a,b,c,d) = (a `HCons` b `HCons` c `HCons` d `HCons` HNil)++instance HTuple '[a,b,c,d,e] (a,b,c,d,e) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil) = (a,b,c,d,e)+    hFromTuple (a,b,c,d,e) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil)++instance HTuple '[a,b,c,d,e,f] (a,b,c,d,e,f) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a,b,c,d,e,f)+    hFromTuple (a,b,c,d,e,f) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil)+++-- | 'tails'+class HTails a b | a -> b, b -> a where+    hTails :: HList a -> HList b++instance HTails '[] '[HList '[]] where+    hTails _ = HCons HNil HNil++instance (HTails xs ys) => HTails (x ': xs) (HList (x ': xs) ': ys) where+    hTails xxs@(HCons _x xs) = xxs `HCons` hTails xs+++-- | 'inits'+class HInits a b | a -> b, b -> a where+    hInits :: HList a -> HList b++instance HInits1 a b => HInits a (HList '[] ': b) where+    hInits xs = HNil `HCons` hInits1 xs+++-- | behaves like @tail . inits@+class HInits1 a b | a -> b, b -> a where+    hInits1 :: HList a -> HList b++instance HInits1 '[] '[HList '[]] where+    hInits1 _ = HCons HNil HNil++instance (HInits1 xs ys,+          HMapCxt HList (FHCons2 x) ys ys',+          HMapCons x ys ~ ys',+          HMapTail ys' ~ ys)+  => HInits1 (x ': xs) (HList '[x] ':  ys') where+    hInits1 (HCons x xs) = HCons x HNil `HCons` hMap (FHCons2 x) (hInits1 xs)+++-- | similar to 'FHCons'+data FHCons2 x = FHCons2 x++instance (hxs ~ HList xs,+          hxxs ~ HList (x ': xs))+  => ApplyAB (FHCons2 x) hxs hxxs where+  applyAB (FHCons2 x) xs = HCons x xs+++-- | evidence to satisfy the fundeps in HInits+type family HMapCons (x :: *) (xxs :: [*]) :: [*]+type instance HMapCons x (HList a ': b) = HList (x ': a) ': HMapCons x b+type instance HMapCons x '[] = '[]++-- | evidence to satisfy the fundeps in HInits+type family HMapTail (xxs :: [*]) :: [*]+type instance HMapTail ( HList (a ': as) ': bs) = HList as ': HMapTail bs+type instance HMapTail '[] = '[]+++-- * partition++{- | @HPartitionEq f x1 xs xi xo@ is analogous to++> (xi,xo) = partition (f x1) xs++where @f@ is a \"function\" passed in using it's instance of 'HEqBy'+-}+class HPartitionEq f x1 xs xi xo | f x1 xs -> xi xo where+    hPartitionEq :: Proxy f -> Proxy x1 -> HList xs -> (HList xi, HList xo)++instance HPartitionEq f x1 '[] '[] '[] where+    hPartitionEq _ _ _ = (HNil, HNil)++instance+   (HEqBy f x1 x b,+    HPartitionEq1 b f x1 x xs xi xo) => HPartitionEq f x1 (x ': xs) xi xo where+      hPartitionEq f x1 (HCons x xs) = hPartitionEq1 (Proxy :: Proxy b) f x1 x xs++class HPartitionEq1 (b :: Bool) f x1 x xs xi xo | b f x1 x xs -> xi xo where+    hPartitionEq1 :: Proxy b -> Proxy f -> Proxy x1 -> x -> HList xs -> (HList xi, HList xo)++instance HPartitionEq f x1 xs xi xo =>+    HPartitionEq1 True f x1 x xs (x ': xi) xo where+      hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of+         (xi, xo) -> (x `HCons` xi, xo)++instance HPartitionEq f x1 xs xi xo =>+    HPartitionEq1 False f x1 x xs xi (x ': xo) where+      hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of+         (xi, xo) -> (xi, x `HCons` xo)+++-- * groupBy++{- | @HGroupBy f x y@ is analogous to @y = 'groupBy' f x@++given that @f@ is used by 'HEqBy'+-}+class HGroupBy (f :: t) (as :: [*]) (gs :: [*]) | f as -> gs, gs -> as where+    hGroupBy :: Proxy f -> HList as -> HList gs++instance (HSpanEqBy f a as fst snd,+          HGroupBy f snd gs) => HGroupBy f (a ': as) (HList (a ': fst) ': gs) where+    hGroupBy f (HCons x xs) = case hSpanEqBy f x xs of+                      (first, second) -> (x `HCons` first) `HCons` hGroupBy f second++instance HGroupBy f '[] '[] where+    hGroupBy _f HNil = HNil++-- * span++-- | @HSpanEq x y fst snd@ is analogous to @(fst,snd) = 'span' (== x) y@+class HSpanEqBy (f :: t) (x :: *) (y :: [*]) (fst :: [*]) (snd :: [*])+      | f x y -> fst snd, fst snd -> y where+  hSpanEqBy :: Proxy f -> x -> HList y -> (HList fst, HList snd)++instance (HSpanEqBy1 f x y fst snd,+          HAppendListR fst snd ~ y)+    => HSpanEqBy f x y fst snd where+  hSpanEqBy f x y =  hSpanEqBy1 f x y++class HSpanEqBy1 (f :: t) (x :: *) (y :: [*]) (i :: [*]) (o :: [*])+      | f x y -> i o where+  hSpanEqBy1 :: Proxy f -> x -> HList y -> (HList i, HList o)++class HSpanEqBy2 (b :: Bool) (f :: t) (x :: *) (y :: *) (ys :: [*]) (i :: [*]) (o :: [*])+      | b f x y ys -> i o where+  hSpanEqBy2 :: Proxy b -> Proxy f -> x -> y -> HList ys -> (HList i, HList o)+++instance (HEqBy f x y b,+          HSpanEqBy2 b f x y ys i o) => HSpanEqBy1 f x (y ': ys) i o where+  hSpanEqBy1 f x (HCons y ys) = hSpanEqBy2 (Proxy :: Proxy b) f x (y :: y) (ys :: HList ys)++instance HSpanEqBy1 f x '[] '[] '[] where+    hSpanEqBy1 _f _x _xs = (HNil, HNil)++instance HSpanEqBy1 f x zs i o+    => HSpanEqBy2 True f x y zs (y ': i) o where+  hSpanEqBy2 _ f x y zs = case hSpanEqBy1 f x zs of+                                      (i, o) -> (HCons y i, o)++instance HSpanEqBy2 False f x y ys '[] (y ': ys) where+  hSpanEqBy2 _b _f _x y ys = (HNil, HCons y ys)++++-- * zip++-- $note see alternative implementations in "Data.HList.HZip"++++instance (SameLengths [x,y,xy], HZipList x y xy) => HUnzip HList x y xy where+  hUnzip = hUnzipList++instance (SameLengths [x,y,xy], HZipList x y xy) => HZip HList x y xy where+  hZip = hZipList+++class HZipList x y l | x y -> l, l -> x y where+  hZipList   :: HList x -> HList y -> HList l+  hUnzipList :: HList l -> (HList x, HList y)++instance HZipList '[] '[] '[] where+  hZipList _ _ = HNil+  hUnzipList _ = (HNil, HNil)++instance ((x,y)~z, HZipList xs ys zs) => HZipList (x ': xs) (y ': ys) (z ': zs) where+  hZipList (HCons x xs) (HCons y ys) = (x,y) `HCons` hZipList xs ys+  hUnzipList (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzipList zs in (x `HCons` xs, y `HCons` ys)++-- * Monoid instance++{- | Analogous to the Monoid instance for tuples++>>> import Data.Monoid+>>> mempty :: HList '[(), All, [Int]]+H[(),All {getAll = True},[]]++>>> mappend (hBuild "a") (hBuild "b") :: HList '[String]+H["ab"]++-}+instance+   (HProxies a,+    HMapCxt HList ConstMempty (AddProxy a) a,+    HZip HList a a aa,+    HMapCxt HList UncurryMappend aa a) => Monoid (HList a) where+  mempty = hMap ConstMempty+            $ (hProxies :: HList (AddProxy a))+#if __GLASGOW_HASKELL__ <= 906+  mappend a b = hMap UncurryMappend $ hZip a b+#endif++instance+    (HZip HList a a aa,+     HMapCxt HList UncurryMappend aa a) => Semigroup (HList a) where+  a <> b = hMap UncurryMappend $ hZip a b++-- ** helper functions++data ConstMempty = ConstMempty+instance (x ~ Proxy y, Monoid y) => ApplyAB ConstMempty x y where+    applyAB _ _ = mempty++data UncurryMappend = UncurryMappend+instance (aa ~ (a,a), Monoid a) => ApplyAB UncurryMappend aa a where+    applyAB _ = uncurry mappend++data UncurrySappend = UncurrySappend+instance (aa ~ (a,a), Semigroup a) => ApplyAB UncurrySappend aa a where+    applyAB _ = uncurry (<>)
Data/HList/HListPrelude.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  {- |    The HList library@@ -13,11 +14,30 @@  import Data.HList.FakePrelude + class HExtend e l where   type HExtendR e l   (.*.) :: e -> l -> HExtendR e l+ infixr 2 .*. ++-- | to keep types shorter, '.*.' used with Proxy avoids+-- producing a @Proxy :: Proxy '[Label x,Label y,Label z]@+-- if @Proxy :: Proxy '[x,y,z]@ is not a kind error (as it+-- is when mixing Label6 and Label3 labels).+--+-- ghc-7.6 does not accept @Proxy ('[] :: [k])@ so for now+-- require @k ~ *@+instance HExtend (Label x) (Proxy ('[] :: [*])) where+    type HExtendR (Label x) (Proxy ('[] :: [*])) = Proxy '[x]+    (.*.) _ _ = Proxy+++-- | similar to 'emptyRecord', 'emptyTIP', emptyHList (actually called 'HNil'),+-- except emptyProxy is the rightmost argument to '.*.'+emptyProxy = Proxy :: Proxy ('[] :: [*])+ -- Poly-kinded class SubType l l' @@ -38,14 +58,14 @@  -- Class to test that a type is "free" in a type sequence -- polykinded-class HOccursNot e l+class HOccursNot (e :: k) (l :: [k])  class HProject l l' where   hProject :: l -> l'  -- | Map a type (key) to a natural (index) within the collection -- This is a purely type-level computation-class HType2HNat e l (n :: HNat) | e l -> n+class HType2HNat (e :: k) (l :: [k]) (n :: HNat) | e l -> n  --  | and lift to the list of types class HTypes2HNats es l (ns :: [HNat]) | es l -> ns@@ -57,4 +77,61 @@  class HDeleteMany e l l' | e l -> l' where   hDeleteMany :: Proxy e -> l -> l'+++class HDeleteAtLabel (r :: [*] -> *) (l :: k) v v' | l v -> v' where+    hDeleteAtLabel :: Label l -> r v -> r v'+++++-- | 'unzip'+class SameLengths [x,y,xy] => HUnzip (r :: [*] -> *) x y xy+        | x y -> xy, xy -> x y where+  hUnzip :: r xy -> (r x, r y)++-- | 'zip'. Variant supports hUnzip, but not hZip ('hZipVariant' returns a Maybe)+class HUnzip r x y xy => HZip (r :: [*] -> *) x y xy where+  hZip :: r x -> r y -> r xy++#if __GLASGOW_HASKELL__ != 706+instance (lv ~ Tagged l v, HUnzip Proxy ls vs lvs)+    => HUnzip Proxy (Label l ': ls) (v ': vs) (lv ': lvs) where+    hUnzip _ = (Proxy, Proxy)++instance HUnzip Proxy '[] '[] '[] where hUnzip _ = (Proxy, Proxy)+++{- | Missing from GHC-7.6.3 due to a bug:++> let r = hEnd $ hBuild 1 2 3+> *Data.HList> hZipList r r+> H[(1,1),(2,2),(3,3)]+> *Data.HList> hZip r r+>+> <interactive>:30:1:+>     Couldn't match type `Label k l' with `Integer'+>     When using functional dependencies to combine+>       HUnzip+>         (Proxy [*]) ((':) * (Label k l) ls) ((':) * v vs) ((':) * lv lvs),+>         arising from the dependency `xy -> x y'+>         in the instance declaration at Data/HList/HListPrelude.hs:96:10+>       HUnzip+>         HList+>         ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+>         ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+>         ((':)+>            *+>            (Integer, Integer)+>            ((':) * (Integer, Integer) ((':) * (Integer, Integer) ('[] *)))),+>         arising from a use of `hZip' at <interactive>:30:1-4+>     In the expression: hZip r r+>     In an equation for `it': it = hZip r r++-}+instance HUnzip Proxy ls vs lvs+      => HZip Proxy ls vs lvs where+  hZip _ _ = Proxy+#endif+
Data/HList/HOccurs.hs view
@@ -20,18 +20,18 @@ -- whose head has the type e. Return HNil if l does not have -- an element of type e. -class HOccurrence e1 (l :: [*]) (l' :: [*]) | e1 l -> l' where-    hOccurrence :: e1 -> HList l -> HList l'+class HOccurrence (e1 :: *) (l :: [*]) (l' :: [*]) | e1 l -> l' where+    hOccurrence :: Proxy e1 -> HList l -> HList l'  instance HOccurrence e1 '[] '[] where     hOccurrence _ = id  instance (HEq e1 e b, HOccurrence' b e1 (e ': l) l')     => HOccurrence e1 (e ': l) l' where-    hOccurrence = hOccurrence' (undefined::Proxy b)+    hOccurrence = hOccurrence' (Proxy::Proxy b) -class HOccurrence' (b :: Bool) e1 (l :: [*]) (l' :: [*]) | b e1 l -> l' where-    hOccurrence' :: Proxy b -> e1 -> HList l -> HList l'+class HOccurrence' (b :: Bool) (e1 :: *) (l :: [*]) (l' :: [*]) | b e1 l -> l' where+    hOccurrence' :: Proxy b -> Proxy e1 -> HList l -> HList l'  instance HOccurrence' True e1 (e ': l) (e ': l) where     hOccurrence' _ _ = id@@ -46,10 +46,10 @@ class HOccursMany e (l :: [*]) where   hOccursMany :: HList l -> [e] -instance (HOccurrence e l l', HOccursMany' e l') +instance (HOccurrence e l l', HOccursMany' e l')     => HOccursMany e l  where-  hOccursMany l = hOccursMany' (hOccurrence (undefined::e) l)+  hOccursMany l = hOccursMany' (hOccurrence (Proxy::Proxy e) l)  class HOccursMany' e l where   hOccursMany' :: HList l -> [e]@@ -65,16 +65,16 @@ -- One or more occurrences  hOccursMany1 :: forall e l l'.-		(HOccurrence e l (e ': l'), HOccursMany e l') =>-		HList l -> (e,[e])-hOccursMany1 l = case hOccurrence (undefined::e) l of-		   (HCons e l') -> (e,hOccursMany (l'::HList l'))+                (HOccurrence e l (e ': l'), HOccursMany e l') =>+                HList l -> (e,[e])+hOccursMany1 l = case hOccurrence (Proxy :: Proxy e) l of+                   (HCons e l') -> (e,hOccursMany (l'::HList l'))  -- -------------------------------------------------------------------------- -- The first occurrence  hOccursFst :: forall e l l'. HOccurrence e l (e ': l') => HList l -> e-hOccursFst l = case hOccurrence (undefined::e) l of HCons e _ -> e+hOccursFst l = case hOccurrence (Proxy::Proxy e) l of HCons e _ -> e  -- -------------------------------------------------------------------------- -- One occurrence and nothing is left@@ -82,26 +82,36 @@  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 (undefined::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' = undefined+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'.+hOccursRest tip = case hOccurs tip of+  x -> (x, hDeleteAtLabel (asLabel x) tip)+  where asLabel :: x -> Label x+        asLabel _ = Label + -- -------------------------------------------------------------------------- -- Zero or at least one occurrence -hOccursOpt :: forall e l l'. -	      (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e-hOccursOpt = hOccursOpt' . hOccurrence (undefined::e)+hOccursOpt :: forall e l l'.+              (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e+hOccursOpt = hOccursOpt' . hOccurrence (Proxy :: Proxy e)  class HOccursOpt' e l where   hOccursOpt' :: HList l -> Maybe e@@ -115,12 +125,15 @@ -- -------------------------------------------------------------------------- -- Class to test that a type is "free" in a type sequence -data TypeFound e-instance HOccursNot e ('[]::[*])-instance (HEq e e1 b, HOccursNot' b e l) => HOccursNot e (e1 ': l)-class HOccursNot' (b :: Bool) e (l :: [*])-instance Fail (TypeFound e) => HOccursNot' True e l-instance HOccursNot e l => HOccursNot' False e l+instance HOccursNot1 e xs xs => HOccursNot e xs++class HOccursNot1 (e :: k) (xs :: [k]) (xs0 :: [k])++instance HOccursNot1 (e :: k) ('[]::[k]) l0+instance (HEq e e1 b, HOccursNot2 b e l l0) => HOccursNot1 e (e1 ': l) l0+class HOccursNot2 (b :: Bool) e (l :: [k]) (l0 :: [k])+instance Fail (ExcessFieldFound e l0) => HOccursNot2 True e l l0+instance HOccursNot1 e l l0 => HOccursNot2 False e l l0   -- --------------------------------------------------------------------------
+ Data/HList/HSort.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE CPP #-}+{- | Description: sorting++Benchmarks for these functions can be found at+<http://code.haskell.org/~aavogt/HList-nodup/Run.html>.++See <Data-HList-CommonMain.html#v:hSort>+for the public interface.++-}+module Data.HList.HSort where++import Data.HList.HList+import Data.HList.FakePrelude+import Data.HList.Label3++#if __GLASGOW_HASKELL__ > 707+import GHC.TypeLits (type (<=?), CmpSymbol)+-- | only in ghc >= 7.7+instance ((x <=? y) ~ b) => HEqBy HLeFn x y b+-- | only in ghc >= 7.7++{- |++>>> let b1 = Proxy :: HEqBy HLeFn "x" "y" b => Proxy b+>>> :t b1+b1 :: Proxy 'True++>>> let b2 = Proxy :: HEqBy HLeFn "x" "x" b => Proxy b+>>> :t b2+b2 :: Proxy 'True++>>> let b3 = Proxy :: HEqBy HLeFn "y" "x" b => Proxy b+>>> :t b3+b3 :: Proxy 'False++-}+instance (HEq (CmpSymbol x y) GT nb, HNot nb ~ b) => HEqBy HLeFn x y b+#endif++-- | the \"standard\" '<=' for types. Reuses 'HEqBy'+--+-- Note that ghc-7.6 is missing instances for Symbol and Nat, so that+-- sorting only works 'HNat' (as used by "Data.HList.Label3").+data HLeFn++instance HEqByFn HLeFn++instance (HLe x y ~ b) => HEqBy HLeFn x y b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Tagged x v) (Tagged y w) b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Label x) (Label y) b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Proxy x) (Proxy y) b++-- | Data.HList.Label3 labels can only be compared if they belong+-- to the same namespace.+instance (HEqBy HLeFn n m b, ns ~ ns')+     => HEqBy HLeFn (Lbl n ns desc) (Lbl m ns' desc') b+++-- | analogous to 'Data.Ord.Down'+data HDown a+instance HEqByFn a => HEqByFn (HDown a)+instance HEqBy f y x b => HEqBy (HDown f) x y b++-- | The HEqBy instances for @HNeq HLeFn@ gives '<'+data HNeq le+instance HEqByFn a => HEqByFn (HNeq a)+instance (HEqBy le y x b1, HNot b1 ~ b2) => HEqBy (HNeq le) x y b2++{- | @HIsAscList le xs b@ is analogous to++> b = all (\(x,y) -> x `le` y) (xs `zip` tail xs)++-}+class HEqByFn le => HIsAscList le (xs :: [*]) (b :: Bool) | le xs -> b++instance HEqByFn le => HIsAscList le '[x] True+instance HEqByFn le => HIsAscList le '[] True+instance (HEqBy le x y b1,+#if __GLASGOW_HASKELL__ > 906+         HEqByFn le,+#endif+         HIsAscList le (y ': ys) b2,+         HAnd b1 b2 ~ b3)  => HIsAscList le (x ': y ': ys) b3+++-- | quick sort with a special case for sorted lists+class (SameLength a b, HEqByFn le) => HSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hSortBy :: Proxy le -> HList a -> HList b++type HSort x y = HSortBy HLeFn x y++hSort :: HSort x y => HList x -> HList y+hSort xs = hSortBy (Proxy :: Proxy HLeFn) xs++instance (SameLength a b,+          HIsAscList le a ok,+          HSortBy1 ok le a b,+          HEqByFn le) => HSortBy le a b where+    hSortBy = hSortBy1 (Proxy :: Proxy ok)++instance HSortBy1 True le a a where+    hSortBy1 _ _ a = a -- already sorted++instance HQSortBy le a b => HSortBy1 False le a b where+    hSortBy1 _ = hQSortBy++class HSortBy1 ok le (a :: [*]) (b :: [*]) | ok le a -> b where+    hSortBy1 :: Proxy ok -> Proxy le -> HList a -> HList b++-- * Merge Sort++{- | HMSortBy is roughly a transcription of this merge sort++> msort [] = []+> msort [x] = [x]+> msort [x,y] = hSort2 x y+> msort xs = case splitAt (length xs `div` 2) xs of+>              (a,b) -> msort a `merge` msort b++> hSort2 x y+>     | x <= y    = [x,y]+>     | otherwise = [y,x]++> merge (x : xs) (y : ys)+>   | x > y     = y : merge (x : xs) ys+>   | otherwise = x : merge xs (y : ys)++-}+class HEqByFn le => HMSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hMSortBy :: Proxy le -> HList a -> HList b+++instance HEqByFn le => HMSortBy le '[] '[] where hMSortBy _ x = x+instance HEqByFn le => HMSortBy le '[x] '[x] where hMSortBy _ x = x+instance (HSort2 b x y ab, HEqBy le x y b, HEqByFn le) =>+    HMSortBy le '[x,y] ab where+      hMSortBy _ (a `HCons` b `HCons` HNil) = hSort2 (Proxy :: Proxy b) a b++class HSort2 b x y ab | b x y -> ab where+    hSort2 :: Proxy b -> x -> y -> HList ab++instance HSort2 True x y '[x,y] where+    hSort2 _ x y = x `HCons` y `HCons` HNil++instance HSort2 False x y '[y,x] where+    hSort2 _ x y = y `HCons` x `HCons` HNil++instance (HMerge le xs' ys' sorted,+#if __GLASGOW_HASKELL__ > 906+          HEqByFn le,+#endif+          HMSortBy le ys ys',+          HMSortBy le xs xs',+          HLengthEq (a ': b ': c ': cs) n2,+          HDiv2 n2 ~ n,+          HSplitAt n (a ': b ': c ': cs) xs ys)+  => HMSortBy le (a ': b ': c ': cs) sorted where+  hMSortBy le abbs = case hSplitAt (Proxy :: Proxy n) abbs of+      (xs, ys) -> hMerge le (hMSortBy le xs) (hMSortBy le ys)+++class HMerge le x y xy | le x y -> xy where+    hMerge :: Proxy le -> HList x -> HList y -> HList xy++instance HMerge le '[] '[] '[] where hMerge _ _ _ = HNil+instance HMerge le (x ': xs) '[] (x ': xs) where hMerge _ x _ = x+instance HMerge le '[] (x ': xs) (x ': xs) where hMerge _ _ x = x++instance (HEqBy le x y b,+          HMerge1 b (x ': xs) (y ': ys) (l ': ls) hhs,+          HMerge le ls hhs srt)+    => HMerge le (x ': xs) (y ': ys) (l ': srt) where+  hMerge le xxs yys = case hMerge1 (Proxy :: Proxy b) xxs yys of+        (HCons l ls, hhs) -> l `HCons` hMerge le ls hhs++type HMerge1 b x y min max = (HCond b (HList x) (HList y) (HList min),+                              HCond b (HList y) (HList x) (HList max))+hMerge1 b x y = (hCond b x y, hCond b y x)++-- * Quick sort+{- | HQSortBy is this algorithm++> qsort (x : xs @ (_ : _)) = case partition (<= x) xs of+>                  (le, gt) -> qsort le ++ x : qsort gt+> qsort xs = xs++on random inputs that are not pathological (ie. not already sorted or reverse+sorted) this turns out to be faster than HMSortBy, so it is used by default.++-}+class HQSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hQSortBy :: Proxy le -> HList a -> HList b++instance HQSortBy le '[] '[] where hQSortBy _ x = x+instance HQSortBy le '[x] '[x] where hQSortBy _ x = x+instance (HPartitionEq le a (b ': bs) bGeq bLt,+        HQSortBy le bLt  sortedLt,+        HQSortBy le bGeq sortedGeq,+        HAppendListR sortedLt (a ': sortedGeq) ~ sorted,+        HAppendList sortedLt (a ': sortedGeq)) =>+    HQSortBy le (a ': b ': bs) sorted where+    hQSortBy le (a `HCons` xs) = case hPartitionEq le (Proxy :: Proxy a) xs of+                      (g,l) -> hQSortBy le l `hAppendList` (a `HCons` hQSortBy le g)+++++-- * More efficient HRLabelSet / HLabelSet+{- | Provided the labels involved have an appropriate instance of HEqByFn,+it would be possible to use the following definitions:++> type HRLabelSet = HSet+> type HLabelSet  = HSet++-}+class HEqByFn lt => 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++{- |++>>> let xx = Proxy :: HIsSet [Label "x", Label "x"] b => Proxy b+>>> :t xx+xx :: Proxy 'False++>>> let xy = Proxy :: HIsSet [Label "x", Label "y"] b => Proxy b+>>> :t xy+xy :: Proxy 'True++-}+class HIsSet (ps :: [*]) (b :: Bool) | ps -> b+instance HIsSetBy (HNeq HLeFn) ps b => HIsSet ps b++class HEqByFn lt => HIsSetBy lt (ps :: [*]) (b :: Bool) | 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 (HEqByFn le, HAscList0 le ps ps) => HAscList le ps++class HEqByFn le => HAscList0 le (ps :: [*]) (ps0 :: [*])++class HEqByFn le => HAscList1 le (b :: Bool) (ps :: [*]) (ps0 :: [*])+instance ( HAscList1 le b (y ': ys) ps0, HEqBy le x y b+#if __GLASGOW_HASKELL__ > 906+         , HEqByFn le+#endif+         )+  => HAscList0 le (x ': y ': ys) ps0+instance HEqByFn le => HAscList0 le '[] ps0+instance HEqByFn le => HAscList0 le '[x] ps0++instance ( Fail '("Duplicated element", y, "using le", le, "in", ys0), HEqByFn le )+    => HAscList1 le False (y ': ys) ys0+instance HAscList0 le ys ys0 => HAscList1 le True ys ys0++{- $setup++>>> import Data.HList.TypeEqO++-}
Data/HList/HTypeIndexed.hs view
@@ -26,8 +26,8 @@ instance HOccursNot e l => HType2HNatCase True e l HZero instance HType2HNat e l n => HType2HNatCase False e l (HSucc n) -hType2HNat :: HType2HNat e l n => Proxy e -> l -> Proxy n-hType2HNat _ _ = undefined+hType2HNat :: HType2HNat e l n => proxy1 e -> proxy l -> Proxy n+hType2HNat _ _ = Proxy  -- | And lift to the list of types @@ -36,9 +36,9 @@ instance (HType2HNat e l n, HTypes2HNats es l ns)       => HTypes2HNats (e ': es) (l :: [*]) (n ': ns) -hTypes2HNats :: HTypes2HNats es l ns => -		Proxy (es :: [*]) -> HList l -> Proxy (ns :: [HNat])-hTypes2HNats = undefined+hTypes2HNats :: HTypes2HNats es l ns =>+                Proxy (es :: [*]) -> hlist l -> Proxy (ns :: [HNat])+hTypes2HNats _ _ = Proxy  -- -------------------------------------------------------------------------- -- Implementing the generic interfaces@@ -48,8 +48,8 @@  instance (HEq e1 e b, HDeleteManyCase b e1 e l l1)       => HDeleteMany e1 (HList (e ': l)) (HList l1) where-  hDeleteMany p (HCons e l) = -      hDeleteManyCase (undefined:: Proxy b) p e l+  hDeleteMany p (HCons e l) =+      hDeleteManyCase (Proxy :: Proxy b) p e l  class HDeleteManyCase (b :: Bool) e1 e l l1 | b e1 e l -> l1 where   hDeleteManyCase :: Proxy b -> Proxy e1 -> e -> HList l -> HList l1@@ -66,24 +66,16 @@ -- -------------------------------------------------------------------------- -- Type-indexed operations in terms of the natural-based primitives -hDeleteAt :: forall e l n. (HDeleteAtHNat n l, HType2HNat e l n) => -	   Proxy e -> HList l -> HList (HDeleteAtHNatR n l)-hDeleteAt _p l = hDeleteAtHNat (undefined :: Proxy n) l+hDeleteAt p l = hDeleteAtHNat (hType2HNat p l) l -hUpdateAt :: forall n e l.-		 (HUpdateAtHNat n e l, HType2HNat e l n) => -		 e -> HList l -> (HList (HUpdateAtHNatR n e l))-hUpdateAt e l = hUpdateAtHNat (undefined:: Proxy n) e l+hUpdateAt e l = hUpdateAtHNat (hType2HNat (Just e) l) e l -hProjectBy :: forall (ns :: [HNat]) (ps :: [*]) (l :: [*]).-	      (HProjectByHNatsCtx ns l, HTypes2HNats ps l ns,-	      ps ~ (HProjectByHNatsR ns l)) =>-	      Proxy ps -> HList l -> HList ps-hProjectBy _ps l = hProjectByHNats (undefined::Proxy ns) l+hProjectBy ps l = hProjectByHNats (hTypes2HNats ps l) l -hSplitBy :: forall (ps :: [*]) l ns.-	    (HProjectByHNatsCtx ns l, HProjectAwayByHNatsCtx ns l,-	     HTypes2HNats ps l ns) =>-	    Proxy ps -> HList l -> (HList (HProjectByHNatsR ns l), -				    HList (HProjectAwayByHNatsR ns l))-hSplitBy _ps l = hSplitByHNats (undefined::Proxy ns) l+hSplitBy ps l = hSplitByHNats (hTypes2HNats ps l) l+++-- | should this instead delete the first element of that type?+instance (HDeleteAtHNat n l, HType2HNat e l n, l' ~ HDeleteAtHNatR n l)+      => HDeleteAtLabel HList e l l' where+    hDeleteAtLabel _ = hDeleteAtHNat (Proxy :: Proxy n)
Data/HList/HZip.hs view
@@ -17,17 +17,7 @@ -- * zip -- ** functional dependency -class HZip x y l | x y -> l, l -> x y where-  hZip   :: HList x -> HList y -> HList l-  hUnzip :: HList l -> (HList x, HList y)--instance HZip '[] '[] '[] where-  hZip _ _ = HNil-  hUnzip _ = (HNil, HNil)--instance ((x,y)~z, HZip xs ys zs) => HZip (x ': xs) (y ': ys) (z ': zs) where-  hZip (HCons x xs) (HCons y ys) = (x,y) `HCons` hZip xs ys-  hUnzip (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip zs in (x `HCons` xs, y `HCons` ys)+-- $note1 moved to "Data.HList.HList" to avoid an orphan instance  -- ** type family -- $note 'hZip2' can be written as a standalone function, with an appropriate@@ -53,7 +43,6 @@   type MapFst (z ': zs) = ( Fst z ': MapFst zs )   type MapSnd (z ': zs) = ( Snd z ': MapSnd zs )   hZip2 (HCons x xs) (HCons y ys) = HCons (x,y) (hZip2 xs ys)-  hZip2 _ _ = error "Data.HList.HZip.hZip2: impossible case"   hUnzip2 (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip2 zs in (x `HCons` xs, y `HCons` ys)  @@ -87,12 +76,12 @@ The original list:  >>> ex-H[H[1, 2], H['a', 'b'], H[3, 5]]+H[H[1,2],H['a','b'],H[3,5]]  And transposed:  >>> hTranspose ex-H[H[1, 'a', 3], H[2, 'b', 5]]+H[H[1,'a',3],H[2,'b',5]]  -} hTranspose x = hFoldr HZipF (hReplicate (hLength (hHead x)) HNil) x@@ -109,7 +98,7 @@ instance HZip3 '[] '[] '[] where   hZip3 _ _ = HNil -instance (HList (x ': y) ~z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where+instance (HList (x ': y) ~ z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where   hZip3 (HCons x xs) (HCons y ys) = HCons x y  `HCons` hZip3 xs ys  data HZipF = HZipF
Data/HList/Keyword.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE OverlappingInstances, StandaloneDeriving #-} -{- | keyword functions+{- | Description: keyword arguments +The public interface is exposed in <Data-HList-CommonMain.html#t:Kw CommonMain#Kw>+ -} module Data.HList.Keyword ( @@ -58,11 +59,13 @@   -- * todo   -- $todo +  -- * internal for type signature prettiness+  TaggedToKW,   ) where  import GHC.TypeLits import Data.HList.FakePrelude-import Data.HList.TypeEqO ()+import Data.HList.TypeEqO import Data.HList.HListPrelude import Data.HList.HList import Data.HList.Record@@ -71,6 +74,7 @@   >>> :set -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses  >>> :set -XScopedTypeVariables -XOverlappingInstances -XTypeFamilies+ >>> :set -fcontext-stack=100  We will be using an example inspired by a graphics toolkit -- the area which really benefits from keyword arguments. We first define our@@ -201,7 +205,7 @@ If we omit a required argument, we get a type error:  > ] testse1 = let f x = kw make_square HNil Color Red x-> ] 	    in "here: " ++ f Origin (0,10)+> ]         in "here: " ++ f Origin (0,10) > >   Couldn't match `ErrReqdArgNotFound Size' against `[Char]' >       Expected type: ErrReqdArgNotFound Size@@ -211,11 +215,11 @@ message if we pass to a keyword function an argument it does not expect:  > ] testse2 = let f x = kw make_square HNil Color Red x-> ] 	    in "here: " ++ f Origin (0,10) Size (1::Int)-> ]	                   RaisedBorder False+> ]         in "here: " ++ f Origin (0,10) Size (1::Int)+> ]                       RaisedBorder False > >   No instances for (Fail (ErrUnexpectedKW RaisedBorder),-> 		    KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char])+>             KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char]) >       arising from use of `f' at ... >     In the second argument of `(++)', namely >   `f Origin (0,10) Size (1 :: Int) RaisedBorder False'@@ -260,7 +264,7 @@ > katest21 = kwapply f2 (Color .*. Red .*. Size .*. (1::Int) .*.  HNil) > > katest3  = kwapply f3 (Size .*. (1::Int) .*. Origin .*. (2.0::Float) .*.-> 		         Color .*. Red .*. HNil)+>                  Color .*. Red .*. HNil)  -} @@ -317,12 +321,7 @@ data ErrReqdArgNotFound x data ErrUnexpectedKW x --- | All our keywords must be registered --class IsKeyFN   t (flag :: Bool) | t-> flag--- | overlapping/fallback case-instance (False ~ flag) => IsKeyFN t flag instance IsKeyFN (Label (s :: Symbol) -> a -> b) True {- ^ labels that impose no restriction on the type of the (single) argument  which follows@@ -365,7 +364,7 @@     kwapply f _ = f  instance (HEq kw kw' flag,-	  KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r)+      KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r)     => KWApply (kw ->a->f') (kw' ': a' ': tail) r where     kwapply = kwapply' (Proxy :: Proxy flag) @@ -376,15 +375,14 @@     => KWApply' True (kw->v->f') (kw ': v' ': tail) r where     kwapply' _ f (HCons kw_ (HCons v' tl)) =                    kwapply (f kw_ v') tl-    kwapply' _ _ _ = error "Data.HList.Keyword.kwapply': impossible 1"  -- | Rotate the arg list ...-instance  (HAppendList tail '[kw , v] ~ l',-	   KWApply f l' r)+instance  (HAppendListR tail '[kw , v] ~ l',+           HAppendList tail '[kw, v],+       KWApply f l' r)     => KWApply' False f (kw ': v ': tail) r where     kwapply' _ f (HCons kw_ (HCons v tl)) =-	kwapply f (hAppend tl (kw_ .*. v .*. HNil))-    kwapply' _ _ _ = error "Data.HList.Keyword.kwapply': impossible 2"+      kwapply f (hAppend tl (kw_ .*. v .*. HNil))  {- | @@ -404,11 +402,10 @@  >>> :t reflect_fk (undefined::Size->Int->Color->CommonColor->String) reflect_fk (undefined::Size->Int->Color->CommonColor->String)-  :: Arg [*] ((':) * Size ((':) * Color ('[] *))) ('[] *)+  :: Arg '[Size, Color] '[]  >>> :t reflect_fk (undefined::Size->Int->()->Int)-reflect_fk (undefined::Size->Int->()->Int)-  :: Arg [*] ((':) * Size ('[] *)) ('[] *)+reflect_fk (undefined::Size->Int->()->Int) :: Arg '[Size] '[]   -}@@ -426,7 +423,7 @@     kwdo :: f -> arg_desc -> HList arg_def -> r  instance (IsKeyFN r rflag,-	    KW' rflag f arg_desc arg_def r)+        KW' rflag f arg_desc arg_def r)     => KW f arg_desc arg_def r where     kwdo = kw' (Proxy ::Proxy rflag) @@ -465,8 +462,8 @@ instance KWMerge' kw arg_def atail arg_values arg_def f r     => KWMerge (kw ': atail) arg_values arg_def f r where     kwmerge (Arg arg_values) arg_def =-	kwmerge' (undefined :: kw) arg_def-	         ((Arg arg_values)::Arg atail arg_values) arg_def+      kwmerge' (undefined :: kw) arg_def+             ((Arg arg_values)::Arg atail arg_values) arg_def  class KWMerge' kw list atail arg_values arg_def f r where     kwmerge':: kw -> HList list -> (Arg atail arg_values) -> HList arg_def -> f -> r@@ -476,7 +473,7 @@                 nff where     kwmerge' = undefined instance (HEq kw kw' flag,-	  KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r)+      KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r)     => KWMerge' kw (kw' ': etc) atail arg_values arg_def f r where     kwmerge' = kwmerge'' (Proxy :: Proxy flag) @@ -484,19 +481,17 @@      where     kwmerge'':: Proxy flag -> kw -> HList list         -> Arg atail arg_values -> HList arg_def-		-> f -> r+        -> f -> r instance KWMerge atail (kw ': v ': arg_values) arg_def f r     => KWMerge'' True kw (kw ': v ': tail)                  atail arg_values arg_def f r where     kwmerge'' _ _ (HCons kw_ (HCons v _)) (Arg arg_values) =-	kwmerge ((Arg (kw_ .*. v .*. arg_values))::-		 (Arg atail (kw ': v ': arg_values)))-    kwmerge'' _ _ _ _ = error "Data.HList.kwmerge'': impossible"+      kwmerge ((Arg (kw_ .*. v .*. arg_values))::+         (Arg atail (kw ': v ': arg_values))) instance KWMerge' kw tail atail arg_values arg_def f r     => KWMerge'' False kw (kw' ': v' ': tail)                  atail arg_values arg_def f r where     kwmerge'' _ kw_ (HCons _ (HCons _ tl)) = kwmerge' kw_ tl-    kwmerge'' _ _ _ = error "Data.HList.kwmerge'': impossible 2"  -- | Add the real argument to the Arg structure, and continue @@ -505,11 +500,11 @@   instance (HDelete kw arg_types arg_types',-	  KW f (Arg arg_types' (kw ': a ': arg_values)) arg_def r)+      KW f (Arg arg_types' (kw ': a ': arg_values)) arg_def r)     => KWAcc (Arg arg_types arg_values) kw a f arg_def r  where     kwaccum (Arg arg_values) kw_ a f =-	kwdo f (Arg (kw_ .*. a .*. arg_values)::-		Arg arg_types' (kw ': a ': arg_values))+      kwdo f (Arg (kw_ .*. a .*. arg_values)::+        Arg arg_types' (kw ': a ': arg_values))   -- | Delete e from l to yield l' The element e must occur in l@@ -581,8 +576,7 @@   -}-recToKW :: forall a b. (HMapAux TaggedToKW a b, SameLength a b,-      SameLength b a, HConcat b) =>+recToKW :: forall a b. (HMapCxt HList TaggedToKW a b, HConcat b) =>      Record a -> HList (HConcatR b) recToKW (Record r) = hConcat (hMap TaggedToKW r :: HList b) @@ -635,7 +629,7 @@  Our implementation is a trivial extension of the strongly-typed polymorphic open records described in-	<http://homepages.cwi.nl/~ralf/HList/>+    <http://homepages.cwi.nl/~ralf/HList/>  In fact, the implementation relies on the HList library.  To run the code (which this message is), one needs to download the HList library
Data/HList/Label3.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  {- | @@ -35,21 +36,41 @@ module Data.HList.Label3 where  import Data.HList.FakePrelude+import Data.HList.HListPrelude+import GHC.TypeLits+import Data.Typeable +{- $setup -data Lbl (x :: HNat) ns desc  -- labels are exclusively type-level entities+>>> let label3 = Label :: Label (Lbl HZero () ())+>>> let label6 = Label :: Label "6" +-} --- Public constructors for labels+data Lbl (x :: HNat) (ns :: *) (desc :: *)  -- labels are exclusively type-level entities+#if !OLD_TYPEABLE+  deriving Typeable+#else+instance (ShowLabel x) => Typeable2 (Lbl x) where+  typeOf2 _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Label3" "Lbl")+    [mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label x)))+      []]+#endif +type instance ZipTagged (Lbl ix ns n ': ts) (v ': vs) = Tagged (Lbl ix ns n) v ': ZipTagged ts vs++instance (Label t ~ Label (Lbl ix ns n)) => SameLabels (Label t) (Lbl ix ns n)++-- * Public constructors for labels+ -- | Construct the first label firstLabel :: ns -> desc -> Label (Lbl HZero ns desc)-firstLabel = undefined+firstLabel _ _ = Label   -- | Construct the next label nextLabel :: Label (Lbl x ns desc) -> desc' -> Label (Lbl (HSucc x) ns desc')-nextLabel = undefined+nextLabel _ _ = Label   -- | Equality on labels (descriptions are ignored)@@ -57,7 +78,7 @@ {- instance ( HEq x x' b          , HEq ns ns' b'-	 , bres ~ HAnd b b'+         , bres ~ HAnd b b'          )       =>   HEq (Lbl x ns desc) (Lbl x' ns' desc') bres -}@@ -67,11 +88,80 @@ instance Show desc => ShowLabel (Lbl x ns desc) where   showLabel = show . getd       where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs-            getd = undefined+            getd = error "Data.HList.Label3 desc"  instance Show desc => Show (Label (Lbl x ns desc))  where   show = show . getd       where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs-            getd = undefined+            getd = error "Data.HList.Label3 desc" +++{- |++If possible, Label is left off:++>>> let q = label3 .*. label3 .*. emptyProxy+>>> :t q+q :: Proxy '[Lbl 'HZero () (), Lbl 'HZero () ()]++-}+instance HExtend (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs)) where+    type HExtendR (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs))+                = Proxy (Lbl n ns desc ': Lbl n' ns' desc' ': xs)+    (.*.) _ _ = Proxy++{- | Mixing two label kinds means we have to include 'Label':++>>> let r = label3 .*. label6 .*. emptyProxy+>>> :t r+r :: Proxy '[Label (Lbl 'HZero () ()), Label "6"]++-}+instance HExtend (Label (Lbl n ns desc)) (Proxy (x ': xs :: [Symbol])) where+    type HExtendR (Label (Lbl n ns desc)) (Proxy (x ': xs))+              = Proxy (Label (Lbl n ns desc) ': MapLabel (x ': xs))+    (.*.) _ _ = Proxy++{- | Mixing two label kinds means we have to include 'Label':++>>> let s = label6 .*. label3 .*. emptyProxy+>>> :t s+s :: Proxy '[Label "6", Label (Lbl 'HZero () ())]++-}+instance HExtend (Label (y :: Symbol)) (Proxy ((x :: *) ': xs)) where+    type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Symbol)) (Proxy ((x :: Nat) ': xs)) where+    type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Nat)) (Proxy ((x :: *) ': xs)) where+    type HExtendR (Label (y :: Nat)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Nat)) (Proxy ((x :: Symbol) ': xs)) where+    type HExtendR (Label (y :: Nat)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++-- | similar to Data.HList.Record.Labels1, but avoids producing Label (Label x)+type family MapLabel (xs :: [k]) :: [*]+type instance MapLabel '[] = '[]+#if NO_CLOSED_TF+-- if we can't have any overlap in the TF (ghc-7.6), cover the Label3/Label6 case+type instance MapLabel ((x :: Symbol) ': xs) = Label x ': MapLabel xs+type instance MapLabel (Lbl n ns desc ': xs) = Label (Lbl n ns desc) ': MapLabel xs+type instance MapLabel (Label x ': xs) = Label x ': MapLabel xs+#else+type instance MapLabel (x ': xs) = AddLabel x ': MapLabel xs+type family AddLabel (x :: k) :: * where+  AddLabel (Label x) = Label x+  AddLabel x = Label x+#endif
+ Data/HList/Label5.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+#if __GLASGOW_HASKELL__ > 906+{-# LANGUAGE LambdaCase #-}+#endif+{- |+   Description: labels are any instance of Typeable++   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Yet another model of labels.++   This model allow us to use any type as label type.+   As a result, we need some generic instances.++   Also, type errors may be more confusing now.+-}++module Data.HList.Label5 where++import Data.Typeable+import Data.Char+import Data.HList.FakePrelude+++-- | Equality on labels++-- instance TypeEq x y b => HEq x y b+++-- | Show label+instance {-# OVERLAPPABLE #-} Typeable (x :: *) => ShowLabel x+ where+  showLabel _ = (\l -> case l of [] -> [] ; (x:xs) -> toLower x:xs)+            . reverse+            . takeWhile (not . (==) '.')+            . reverse+            . show+{-+            . tyConString+            . typeRepTyCon+-}+            . typeOf $ (error "Data.HList.Label5 has a strict typeOf" :: x)
Data/HList/Label6.hs view
@@ -12,7 +12,7 @@    Labels are promoted Strings or Integers "GHC.TypeLits" inside the    'Label'. Needs ghc7.6 or higher. -   See "Data.HList.CommonMain#label6demo" for an example.+   See <Data-HList-CommonMain.html#label6demo CommonMain#label6demo> for an example.  -} @@ -20,11 +20,36 @@  import Data.HList.FakePrelude import GHC.TypeLits+import Data.HList.HListPrelude  #if MIN_VERSION_base(4,7,0) instance KnownSymbol x => ShowLabel (x :: Symbol) where   showLabel _ =  symbolVal (Proxy :: Proxy x)+instance KnownNat x => ShowLabel (x :: Nat) where+  showLabel _ =  show $ natVal (Proxy :: Proxy x) #else instance SingI x => ShowLabel (x :: Symbol) where   showLabel _ =  fromSing (sing :: Sing x)++instance SingI x => ShowLabel (x :: Nat) where+  showLabel _ =  show (fromSing (sing :: Sing x)) #endif++++{- |++>>> let labelX = Label :: Label "x"+>>> let labelY = Label :: Label "y"+>>> let p = labelX .*. labelY .*. emptyProxy+>>> :t p+p :: Proxy '["x", "y"]++-}+instance HExtend (Label (y :: Symbol)) (Proxy (x ': xs :: [Symbol])) where+    type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs)+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Nat)) (Proxy (x ': xs :: [Nat])) where+    type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs)+    (.*.) _ _ = Proxy
Data/HList/Labelable.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-} {- | -Description : labels which are also lenses+Description : labels which are also lenses (or prisms)  A simple problem is being solved here, but unfortunately it-is a bit involved. The idea is to use the same haskell identifier +is a bit involved. The idea is to use the same haskell identifier for a lens and for other purposes. In other words, get the same behavior as: @@ -20,125 +18,204 @@ Elaboration of some ideas from edwardk. -} module Data.HList.Labelable-    (makeLabelable,-     Labelable(hLens'),+    (Labelable(..),+     LabeledOptic,      (.==.), ++     -- * multiple lookups+     Projected(..), projected',+     -- * comparison with 'hLens'     -- $comparisonWithhLensFunction      -- * likely unneeded (re)exports-    -- $note needed to make a needed instance visible-    Labeled(Labeled),-    toLabel,+    LabeledCxt1,+    LabeledTo(LabeledTo),+    LabeledR(LabeledR),+    ToSym, EnsureLabel(toLabel), toLabelSym,     Identity,-    ToSym,+    LabelableTIPCxt,+    LabeledOpticType(..),++    LabeledOpticF,+    LabeledOpticP,+    LabeledOpticTo,     ) where  ++import Data.HList.HListPrelude import Data.HList.FakePrelude-import Data.HList.HArray-import Data.HList.HList import Data.HList.Record+import Data.HList.Variant+import Data.HList.TIP+import Data.HList.TIC+import Data.HList.Label3  import Control.Monad.Identity import GHC.TypeLits+import LensDefs+import GHC.Exts (Constraint) -import Language.Haskell.TH+{- | This alias is the same as Control.Lens.Optic, except the (->) in Optic+is a type parameter 'to' in LabeledOptic. -{- | @f s t a b@ type parameters are the same as those that make-"Control.Lens" work.+Depending on the collection type (see instances of 'LabelableTy'),+the type variables @to, p, f@ are constrained such that the resulting+type is a @Lens (r s) (r t) a b@, @Prism (r s) (r t) a b@ or a+@LabeledTo x _ _@. The latter can be used to recover the label (@x@) when+used as an argument to '.==.' or equivalently 'toLabel'.+-}+type LabeledOptic (x :: k) (r :: [*] -> *) (s :: [*]) (t :: [*]) (a :: *) (b :: *)+    = forall ty to p f.+                     (ty ~ LabelableTy r,+                      LabeledOpticF ty f,+                      LabeledOpticP ty p,+                      LabeledOpticTo ty x to) => (a `p` f b) `to` (r s `p` f (r t)) -[@n@] is the index in the HList at which the value will be found+data LabeledOpticType = LabelableLens | LabelablePrism | LabelableLabel -[@l@] is the label for the field (tends to be 'GHC.TypeLits.Symbol')+type family LabeledOpticF (ty :: LabeledOpticType) :: (* -> *) -> Constraint+type instance LabeledOpticF LabelableLens = Functor+type instance LabeledOpticF LabelablePrism = Applicative+type instance LabeledOpticF LabelableLabel = (~) Identity -[@p@] is @->@ when the result is used as a lens, or 'Labeled' when used-      as an argument to '.==.'+type family LabeledOpticP (ty :: LabeledOpticType) :: (* -> * -> *) -> Constraint+type instance LabeledOpticP LabelableLens = (~) (->)+type instance LabeledOpticP LabelablePrism = Choice+type instance LabeledOpticP LabelableLabel = (~) (->) --}-class Labelable l p f s t a b-#if MIN_VERSION_base(4,7,0)-     {- no fundeps in this case: they are potentially inconsistent-        according to ghc-7.8-        <http://ghc.haskell.org/trac/ghc/ticket/2247>+type family LabeledOpticTo (ty :: LabeledOpticType) (x :: k) :: (* -> * -> *) -> Constraint+type instance LabeledOpticTo LabelableLens x = (~) (->)+type instance LabeledOpticTo LabelablePrism x = (~) (->)+type instance LabeledOpticTo LabelableLabel x = (~) (LabeledTo x) -        these fundeps are mostly documentation, since the two-        instances have contexts that encode roughly the same-        dependencies provided you choose a specific `p'-     -}-#else-        | l s -> a, l t -> b,     -- lookup-          l s b -> t, l t a -> s  -- update-#endif++{- |++[@r@] is 'Record', 'Variant'. 'TIP' and 'TIC' also have instances, but generally+'tipyLens'' and 'ticPrism'' are more appropriate.++[@x@] is the label for the field. It tends to have kind 'GHC.TypeLits.Symbol',+but others are supported in principle.++-}+class SameLength s t => Labelable (x :: k) (r :: [*] -> *) s t a b+          | x s -> a, x t -> b,    -- lookup+            x s b -> t, x t a -> s -- update   where-    hLens' :: Label l -> p (a -> f b) (Record s -> f (Record t))+    type LabelableTy r :: LabeledOpticType+    hLens' :: Label x -> LabeledOptic x r s t a b -data Labeled (l :: k) (a :: *) (b :: *) = Labeled deriving (Show)+data LabeledTo (x :: k) (a :: *) (b :: *) = LabeledTo deriving (Show) --- | make a lens-instance (Functor f,-          HasField x (Record s) a,-          HasField x (Record t) b,-          HFind x (RecordLabels t) n,-          HFind x (RecordLabels s) n,-          HUpdateAtHNat n (Tagged x b) s,-          t ~ HUpdateAtHNatR n (Tagged x b) s)-        => Labelable x (->) f s t a b where-            hLens' lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab))+data LabeledR (x :: [*]) = LabeledR --- | make a data type that allows recovering the field name-instance (f ~ Identity, s ~ '[], t ~ '[], a ~ (), b ~ (),-           x' ~ x) => Labelable x' (Labeled x) f s t a b where-        hLens' _ = Labeled :: Labeled x (a -> f b) (Record s -> f (Record t))+{- if __GLASGOW_HASKELL__ > 800+-- should this orphan instance really be supplied? ghc 8's+-- -XOverloadedLabels is uglier syntax than HListPP, and it+-- seems likely that other users of IsLabel probably define+-- an instance for (->) which will be chosen over this one+-- when labels are composed with (.),+-- (or alternatively there will be complaints about overlap)+instance (x ~ x', Labelable x r s t a b) => IsLabel x (LabeledOptic x' r s t a b) where+    fromLabel _ = hLens' (Label :: Label x)+-- endif+-}  +-- | make a @Lens (Record s) (Record t) a b@+instance HLens x Record s t a b+        => Labelable x Record s t a b where+            type LabelableTy Record = LabelableLens+            hLens' x = hLens x++-- | used with 'toLabel' and/or '.==.'+instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where+        type LabelableTy LabeledR = LabelableLabel+        hLens' _ = LabeledTo++-- | sets all type variables to dummy values: only the @Labeled x@+-- part is actually needed+type LabeledCxt1 s t a b = (s ~ '[], t ~ '[], a ~ (), b ~ ())++-- | make a @Prism (Variant s) (Variant t) a b@+instance (HPrism x s t a b,+          to ~ (->)) => Labelable x Variant s t a b where+    type LabelableTy Variant = LabelablePrism+    hLens' x s = hPrism x s++-- | @hLens' :: Label a -> Prism' (TIC s) a@+--+-- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@,+-- cannot have an instance of Labelable+--+-- 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 :: k) TIC s t a b where+      type LabelableTy TIC = LabelablePrism+      hLens' _ = ticPrism+++-- | make a @Lens' (TIP s) a@.+--+-- '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 :: k) TIP s t a b where+    type LabelableTy TIP = LabelableLens+    hLens' x = hLens x++type LabelableTIPCxt x s t a b =+     (s ~ t, a ~ b, Label x ~ Label a,+      HLens x TIP s t a b)++ -- | modification of '.=.' which works with the labels from this module, -- and those from "Data.HList.Label6". Note that this is not strictly a -- generalization of '.=.', since it does not work with labels like -- "Data.HList.Label3" which have the wrong kind. l .==. v = toLabel l .=. v +infixr 4 .==. --- | extracts the type that is actually the label in @a@ and puts it in @b@-class ToSym a b+-- | Get the Symbol out of a 'Label' or 'LabeledTo'+class ToSym label (s :: Symbol) | label -> s --- | for labels in this module-instance (x ~ x', p ~ Labeled x') => ToSym (p a b) x'+instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3+    => ToSym (v1 v2 v3) x --- | for "Data.HList.Label6" labels-instance (x ~ x') => ToSym (Label x) x'+instance ToSym (label x) x -toLabel :: ToSym t t' => t -> Label (t' :: Symbol)-toLabel _ = Label+{- | 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 EnsureLabel x y | x -> y where+  toLabel :: x -> y -{- | @makeLabelable \"x y z\"@ will generate haskell identifiers that work with '.==.' and-are also lenses.+instance EnsureLabel (Label x) (Label (x :: k)) where+  toLabel _ = Label -> x = hLens' (Label :: Label "x")-> y = hLens' (Label :: Label "y")-> z = hLens' (Label :: Label "z")+instance EnsureLabel (Proxy x) (Label (x :: k)) where+  toLabel _ = Label --}-makeLabelable :: String -> Q [Dec]-makeLabelable xs = fmap concat $ mapM makeLabel1 (words xs)-    where-        -- a bit indirect, ghc-7.6 TH is a bit too eager to reject-        -- mis-matched kind variables-        makeLabel1 x = sequence-              [-                sigD (mkName x) makeSig,-                valD (varP (mkName x)) (normalB (varE 'hLens' `appE` lt))-                            []-                ]-            where lt = [| Label :: $([t| Label $l |]) |]-                  l = litT (strTyLit x)+-- | 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 -                  makeSig = [t| Labelable $l p f s t a b => p (a -> f b) (Record s -> f (Record t)) |] +-- | 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@@ -159,10 +236,120 @@  > -- with the x defined as x = Label :: Label "x"  > let f x r = let  >          a = r ^. hLens x- >          b = r & hLens x .~ "6"+ >          b = r & hLens x .~ "7"  >        in (a,b)  It may work to use 'hLens'' instead of 'hLens' in the second code, but that is a bit beside the point being made here. +The same points apply to the use of 'hPrism' over 'hLens''.+ -}++{- | Sometimes it may be more convenient to operate on a record/variant+that only contains the fields of interest. 'projected' can then be used+to apply that function to a record that contains additional elements.+++>>> :set -XViewPatterns+>>> import Data.HList.RecordPuns+>>> let f [pun| (x y) |] = case x+y of z -> [pun| z |]+>>> :t f+f :: Num v =>+     Record '[Tagged "x" v, Tagged "y" v] -> Record '[Tagged "z" v]++>>> let r = (let x = 1; y = 2; z = () in [pun| x y z |])+>>> r+Record{x=1,y=2,z=()}++>>> r & sameLabels . projected %~ f+Record{x=1,y=2,z=3}+++++-}+class Projected r s t a b where+    projected :: (ty ~ LabelableTy r,+                LabeledOpticP ty p,+                LabeledOpticF ty f) => r a `p` f (r b) -> r s `p` f (r t)++-- | @Lens rs rt ra rb@+--+-- where @rs ~ Record s, rt ~ Record t, ra ~ Record a, rb ~ Record b@+instance (-- for Record s -> Record a+          H2ProjectByLabels (LabelsOf a) s a_ _s_minus_a,+          HRLabelSet a_, HRLabelSet a,+          HRearrange (LabelsOf a) a_ a,++          HLeftUnion b s bs, HRLabelSet bs,+          HRearrange (LabelsOf t) bs t, HRLabelSet t+        ) => Projected Record s t a b where+    projected f s = (\b -> hRearrange' (b .<++. s)) <$> f (hProjectByLabels' s :: Record a)++-- | @Prism (Variant s) (Variant t) (Variant a) (Variant b)@+instance (ExtendsVariant b t,+          ProjectVariant s a,+          ProjectExtendVariant s t,++          HLeftUnion b s bs, HRLabelSet bs,+          HRearrange (LabelsOf t) bs t)+      => Projected Variant s t a b where+    projected = prism extendsVariant+            (\s -> case projectVariant s of+                    Just a -> Right a+                    Nothing | Just t <- projectExtendVariant s -> Left t+                    _ -> error "Data.HList.Labelable.projected impossible"+                    -- projectExtendVariant gives Nothing when the element of+                    -- `t` that is actually stored in the variant comes+                    -- from the `b`. But in that case the projectVariant+                    -- above must have been Just+              )+++{- | @Lens' (Record s) (Record a)@++@Prism' (Variant s) (Variant a)@+-}+projected' s = isSimple projected s+++{- | Together with the instance below, this allows writing++@+'makeLabelable' "x y z"+p = x .*. y .*. z .*. 'emptyProxy'+@++Or with HListPP++@+p = `x .*. `y .*. `z .*. emptyProxy+@++instead of++> p = Proxy :: Proxy ["x","y","z"]++-}+instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy ('[] :: [*])) where+    type HExtendR (to p q) (Proxy ('[] :: [*])) = Proxy '[GetXFromLabeledTo to]+    (.*.) _ _ = Proxy++instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy (x ': xs)) where+    type HExtendR (to p q) (Proxy (x ': xs)) = Proxy (GetXFromLabeledTo to ': x ': xs)+    (.*.) _ _ = Proxy++-- | if the proxy has Data.HList.Label3."Lbl", then everything has to be+-- wrapped in Label to make the kinds match up.+instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy (Lbl n ns desc ': xs)) where+    type HExtendR (to p q) (Proxy (Lbl n ns desc ': xs))+        = Proxy (Label (GetXFromLabeledTo to) ': MapLabel (Lbl n ns desc ': xs))+    (.*.) _ _ = Proxy++type family GetXFromLabeledTo (to :: * -> * -> *) :: Symbol+type instance GetXFromLabeledTo (LabeledTo x) = x+
Data/HList/MakeLabels.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}  {- | Description : Automate some of the ways to make labels.@@ -7,12 +8,16 @@ module Data.HList.MakeLabels (     makeLabels,     makeLabels3,++    -- * labels using kind 'Symbol'     makeLabels6,-    -- | see also 'Data.HList.Labelable.makeLabelable'+    makeLabelable,     ) where +import Data.Typeable import Data.HList.FakePrelude import Data.HList.Label3+import Data.HList.Labelable  import Language.Haskell.TH import Data.Char@@ -30,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) |] @@ -39,13 +51,6 @@                   (normalB [| Label |])                   [] -    showLabelInst = instanceD-            (return [])-            [t| ShowLabel $(conT c) |]-            [valD (varP 'showLabel)-                (normalB [| \_ -> n |])-                [] ]-     showInst = instanceD             (return [])             [t| Show $(conT c) |]@@ -59,13 +64,12 @@          dd, -        showLabelInst,         showInst ]   {- | -Labels like "Data.HList.Label4" used to provide (only no Typeable).+Labels like "Data.HList.Label5".   The following TH declaration splice should be placed at top-level, before the  created values are used. Enable @-XTemplateHaskell@ too.@@ -74,21 +78,16 @@  should expand into the following declarations -> data LabelGetX-> data LabelGetY-> data LabelDraw-> data LabelX+> data LabelGetX deriving Typeable+> data LabelGetY deriving Typeable+> data LabelDraw deriving Typeable+> data LabelX deriving Typeable  > getX = Label :: Label LabelGetX > getY = Label :: Label LabelGetY > draw = Label :: Label LabelDraw > x    = Label :: Label LabelX --> instance ShowLabel LabelGetX where showLabel = \_ -> "getX"-> instance ShowLabel LabelGetY where showLabel = \_ -> "getY"-> instance ShowLabel LabelDraw where showLabel = \_ -> "draw"- -} makeLabels :: [String] -> Q [Dec] makeLabels = fmap concat . mapM dcl@@ -117,8 +116,45 @@ -- possibly there is a better option makeLabels3 ns [] = fail ("makeLabels3 "++ ns ++ " []") --- | for "Data.HList.Label6"+{- | for "Data.HList.Label6"++> makeLabels6 ["x","y"]++is a shortcut for++> x = Label :: Label "x"+> y = Label :: Label "y"++-} makeLabels6 :: [String] -> Q [Dec] makeLabels6 ns = fmap concat $ forM ns $ \n -> sequence   [sigD (make_dname n) [t| Label $(litT (strTyLit n)) |],    valD (varP (make_dname n)) (normalB [| Label |]) []]+++{- | @makeLabelable \"x y z\"@ expands out to++> x = hLens' (Label :: Label "x")+> y = hLens' (Label :: Label "y")+> z = hLens' (Label :: Label "z")++Refer to "Data.HList.Labelable" for usage.++-}+makeLabelable :: String -> Q [Dec]+makeLabelable xs = fmap concat $ mapM makeLabel1 (words xs)+    where+        -- a bit indirect, ghc-7.6 TH is a bit too eager to reject+        -- mis-matched kind variables+        makeLabel1 x = sequence+              [+                sigD (mkName x) makeSig,+                valD (varP (mkName x)) (normalB (varE 'hLens' `appE` lt))+                            []+                ]+            where lt = [| Label :: $([t| Label $l |]) |]+                  l = litT (strTyLit x)++                  makeSig = [t| forall r s t a b. (Labelable $l r s t a b) =>+                              LabeledOptic $l r s t a b+                              |]
Data/HList/Record.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP #-} {- |    The HList library @@ -10,9 +10,13 @@     * "Data.HList.Label3" -   * "Data.HList.MakeLabels"+   * "Data.HList.Label5" +   * "Data.HList.Label6" +   * "Data.HList.Labelable"++    These used to work:     * "Data.HList.Label1"@@ -21,8 +25,6 @@     * "Data.HList.Label4" -   * "Data.HList.Label5"- -}  module Data.HList.Record@@ -35,24 +37,34 @@     -- ** Labels     -- $labels     module Data.Tagged,-    (.=.), (.-.),+    (.=.),      -- ** Record     Record(..),     mkRecord,     emptyRecord,+    hEndR,+    hEndP, -    -- *** Getting Labels-    RecordLabels,-    recordLabels,+    hListRecord, hListRecord', +    -- *** Getting Labels     LabelsOf,-    hLabels,+    labelsOf,+    asLabelsOf,      -- *** Getting Values     RecordValues(..),     recordValues,+    hMapTaggedFn, +    unlabeled0,++    Unlabeled,+    unlabeled,+    Unlabeled',+    unlabeled',+     -- * Operations     -- ** Show     -- | A corresponding 'Show' instance exists as@@ -61,42 +73,53 @@     ShowComponents(..),     ShowLabel(..), +    -- ** Extension+    -- | 'hExtend', 'hAppend'+    (.*.),      -- ** Delete     -- | 'hDeleteAtLabel' @label record@-    hDeleteAtLabel,+    (.-.),+    HDeleteLabels(..),      -- ** Lookup/update     -- $lens-    hLens,+    HLens(hLens),      -- ** Lookup     HasField(..),-    HasField'(..),+    HasFieldM(..),     (.!.),      -- ** Update     (.@.),-    hUpdateAtLabel,+    HUpdateAtLabel(hUpdateAtLabel),     -- *** type-preserving versions-    -- $note these restrict the resulting record type to be the same as in+    -- | Note: these restrict the resulting record type to be the same as in     -- input record type, which can help reduce the number of type annotations     -- needed     (.<.),+    HTPupdateAtLabel,     hTPupdateAtLabel,      -- ** Rename Label     hRenameLabel,      -- ** Projection++    Labels,+     -- $projection     hProjectByLabels,+    hProjectByLabels',     hProjectByLabels2, +    -- *** a lens for projection+    -- | see "Data.HList.Labelable".'Projected'+     -- ** Unions     -- *** Left     HLeftUnion(hLeftUnion),-    HLeftUnionBool(hLeftUnionBool),     (.<++.),      -- *** Symmetric@@ -106,40 +129,78 @@      -- ** Reorder Labels     hRearrange,+    hRearrange', -    -- ** Extension-    -- | 'hExtend', 'hAppend'-    (.*.),+    -- *** isos using hRearrange+    Rearranged(rearranged), rearranged',  +    -- ** Apply a function to all values+    hMapR, HMapR(..),++    -- ** cast labels+    Relabeled(relabeled),+    relabeled',+     -- * Hints for type errors     DuplicatedLabel,-    ExtraField(..),-    FieldNotFound(..),+    ExtraField,+    FieldNotFound,      -- * Unclassified+     -- | Probably internals, that may not be useful+#if __GLASGOW_HASKELL__ != 706+    zipTagged,+#endif+    HasField'(..),+    DemoteMaybe,+    HasFieldM1(..),     H2ProjectByLabels(h2projectByLabels),     H2ProjectByLabels'(h2projectByLabels'),     HLabelSet,     HLabelSet',     HRLabelSet,-    HRLabelSet',+    HAllTaggedLV,     HRearrange(hRearrange2),-    HRearrange'(hRearrange2'),+    HRearrange3(hRearrange3),+    HRearrange4(hRearrange4),     UnionSymRec'(..),+    HFindLabel,     labelLVPair,     newLVPair,+    UnLabel,+    HMemberLabel,+    TaggedFn(..),+    ReadComponent,+    HMapTaggedFn,+    HLensCxt,++    -- ** zip+    -- | use the more general 'HZip' class instead+    HZipRecord(..),+    -- *** alternative implementation+    hZipRecord2, hUnzipRecord2 ) where   import Data.HList.FakePrelude import Data.HList.HListPrelude import Data.HList.HList-import Data.HList.HArray +import Data.HList.Label3 (MapLabel)+ import Data.Tagged- +import Control.Monad++import Text.ParserCombinators.ReadP++import LensDefs++import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif -- imports for doctest/examples import Data.HList.Label6 () import Data.HList.TypeEqO ()@@ -187,46 +248,122 @@ l .=. v = newLVPair l v  -newtype Record (r :: [*]) = Record (HList r) -- deriving Eq+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)+deriving instance (Ix (HList r)) => Ix (Record r)+deriving instance (Bounded (HList r)) => Bounded (Record r) + -- | Build a record mkRecord :: HRLabelSet r => HList r -> Record r mkRecord = Record +-- | @HRLabelSet t => Iso (HList s) (HList t) (Record s) (Record t)@+hListRecord x = isoNewtype mkRecord (\(Record r) -> r) x +-- | @Iso' (HList s) (Record s)@+hListRecord' x = isSimple hListRecord x+ -- | Build an empty record emptyRecord :: Record '[] emptyRecord = mkRecord HNil +-- | @Iso (Record s) (Record t) (HList a) (HList b)@+--+-- @view unlabeled == 'recordValues'@+unlabeled0 x = sameLabels (iso recordValues hMapTaggedFn x) --- | Propery of a proper label set for a record: no duplication of labels +unlabeled :: (Unlabeled x y, Profunctor p, Functor f) =>+    (HList (RecordValuesR x) `p` f (HList (RecordValuesR y))) ->+    (Record x `p` f (Record y))+unlabeled x = sameLength (unlabeled0 (sameLength x))++type Unlabeled x y =+      (HMapCxt HList TaggedFn (RecordValuesR y) y,+       RecordValues x, RecordValues y,+       SameLength (RecordValuesR x) (RecordValuesR y),+       SameLength x y, SameLabels x y,+       HAllTaggedLV x, HAllTaggedLV y)+type Unlabeled' x = Unlabeled x x++++-- | @Unlabeled' x => Iso' (Record x) (HList (RecordValuesR x))@+unlabeled' :: (Unlabeled' x, Profunctor p, Functor f) =>+    (HList (RecordValuesR x) `p` f (HList (RecordValuesR x))) ->+    (Record x `p` f (Record x))+unlabeled' = unlabeled++{- | @Iso (Record s) (Record t) (Record a) (Record b)@, such that+@relabeled = unlabeled . from unlabeled@++in other words, pretend a record has different labels, but the same values.++-}+class Relabeled r where+  relabeled :: forall p f s t a b.+      (HMapTaggedFn (RecordValuesR s) a,+       HMapTaggedFn (RecordValuesR b) t,+       SameLengths '[s,a,t,b],+       RecordValuesR t ~ RecordValuesR b,+       RecordValuesR s ~ RecordValuesR a,+       RecordValues b, RecordValues s,+       Profunctor p,+       Functor f+       ) => r a `p` f (r b) -> r s `p` f (r t)++instance Relabeled Record where+  relabeled = iso+    (\ s -> hMapTaggedFn (recordValues s))+    (\ b -> hMapTaggedFn (recordValues b))+    -- isoNewtype should be safe here, but there are no guarantees+    -- http://stackoverflow.com/questions/24222552++-- | @Iso' (Record s) (Record a)@+--+-- such that @RecordValuesR s ~ RecordValuesR a@+relabeled' x = isSimple relabeled x++data TaggedFn = TaggedFn+instance (tx ~ Tagged t x) => ApplyAB TaggedFn x tx where+    applyAB _ = Tagged++type HMapTaggedFn l r =+    (HMapCxt HList TaggedFn l r,+     RecordValuesR r ~ l,+     RecordValues r)++-- | \"inverse\" to 'recordValues'+hMapTaggedFn :: HMapTaggedFn a b => HList a -> Record b+hMapTaggedFn = Record . hMap TaggedFn++-- | Property of a proper label set for a record: no duplication of labels,+-- and every element of the list is @Tagged label value@+ data DuplicatedLabel l -class HRLabelSet (ps :: [*])-instance HRLabelSet '[]-instance HRLabelSet '[x]-instance ( HEq l1 l2 leq-         , HRLabelSet' l1 l2 leq r-         ) => HRLabelSet (Tagged l1 v1 ': Tagged l2 v2 ': r)+class (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*])+instance (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*]) -class HRLabelSet' l1 l2 (leq::Bool) (r :: [*])-instance ( HRLabelSet (Tagged l2 () ': r)-         , HRLabelSet (Tagged l1 () ': r)-         ) => HRLabelSet' l1 l2 False r-instance ( Fail (DuplicatedLabel l1) ) => HRLabelSet' l1 l2 True r  --- | Relation between HLabelSet and HRLabelSet-{--instance (HZip ls vs ps, HLabelSet ls) => HRLabelSet ps++{- | Relation between HLabelSet and HRLabelSet++> instance HLabelSet (LabelsOf ps) => HRLabelSet ps++see also 'HSet' -}  class HLabelSet ls instance HLabelSet '[] instance HLabelSet '[x]-instance ( HEq l1 l2 leq+instance ( HEqK l1 l2 leq          , HLabelSet' l1 l2 leq r          ) => HLabelSet (l1 ': l2 ': r) @@ -236,40 +373,53 @@          ) => HLabelSet' l1 l2 False r instance ( Fail (DuplicatedLabel l1) ) => HLabelSet' l1 l2 True r --- | Construct the (phantom) list of labels of the record.---+-- | Construct the (phantom) list of labels of a record,+-- or list of Label.+type family LabelsOf (ls :: [*]) :: [*]+type instance LabelsOf '[] = '[]+type instance LabelsOf (Label l ': r)  = Label l ': LabelsOf r+type instance LabelsOf (Tagged l v ': r) = Label l ': LabelsOf r -type family RecordLabels (r :: [*]) :: [k]-type instance RecordLabels '[]               = '[]-type instance RecordLabels (Tagged l v ': r) = l ': RecordLabels r+labelsOf :: hlistOrRecord l -> Proxy (LabelsOf l)+labelsOf _ = Proxy -recordLabels :: Record r -> Proxy (RecordLabels r)-recordLabels _ = Proxy  +-- | remove the Label type constructor. The @proxy@ argument is+-- supplied to make it easier to fix the kind variable @k@.+type family UnLabel (proxy :: k) (ls :: [*]) :: [k]+type instance UnLabel proxy (Label x ': xs) = x ': UnLabel proxy xs+type instance UnLabel proxy '[] = '[]++-- | A version of 'HFind' where the @ls@ type variable is a list of+-- 'Tagged' or 'Label'. This is a bit indirect, and ideally LabelsOf+-- could have kind [*] -> [k].+type HFindLabel (l :: k) (ls :: [*]) (n :: HNat) = HFind l (UnLabel l (LabelsOf ls)) n+ -- | Construct the HList of values of the record.-class RecordValues (r :: [*]) where+class SameLength r (RecordValuesR r)+      => RecordValues (r :: [*]) where   type RecordValuesR r :: [*]   recordValues' :: HList r -> HList (RecordValuesR r)  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)  recordValues :: RecordValues r => Record r -> HList (RecordValuesR r) recordValues (Record r) = recordValues' r ---- | Making this ls::[*] and [k] breaks the MainGhcGeneric1.hs...-type family LabelsOf (ls :: [*]) :: [*]-type instance LabelsOf '[] = '[]-type instance LabelsOf (Label l ': r)  = l ': LabelsOf r+{- shorter, but worse in terms needing annotations to allow ambiguous types+- but better in terms of inference+recordValues :: RecordValues r rv => Record r -> HList rv+recordValues (Record r) = hMap HUntag r -hLabels :: HList l -> Proxy (LabelsOf l)-hLabels _ = Proxy+type RecordValues r rv = HMapCxt HUntag r rv+-}  -- -------------------------------------------------------------------------- @@ -299,15 +449,66 @@      ++ showComponents "," r  +-- -------------------------------------------------------------------------- +-- 'Read' instance to appeal to normal records ++data ReadComponent = ReadComponent Bool -- ^ include comma?++instance (Read v, ShowLabel l,+          x ~ Tagged l v,+          ReadP x ~ y) =>+  ApplyAB ReadComponent (Proxy x) y where+    applyAB (ReadComponent comma) _ = do+      when comma (() <$ string ",")+      _ <- string (showLabel (Label :: Label l))+      _ <- string "="+      v <- readS_to_P reads+      return (Tagged v)+++instance (HMapCxt HList ReadComponent (AddProxy rs) bs,+          ApplyAB ReadComponent (Proxy r) readP_r,+          HProxies rs,+          HSequence ReadP (readP_r ': bs) (r ': rs),+          readP_r ~ ReadP (Tagged l v),++          -- ghc-8.0.2 needs these. The above constraints+          -- should imply them+          r ~ Tagged l v,+          ShowLabel l,+          Read v,+          HSequence ReadP bs rs+          ) => Read (Record (r ': rs)) where+    readsPrec _ = readP_to_S $ do+        _ <- string "Record{"+        content <- hSequence parsers+        _ <- string "}"+        return (Record content)++      where+        rs :: HList (AddProxy rs)+        rs = hProxies++        readP_r :: readP_r+        readP_r = applyAB+                      (ReadComponent False)+                      (Proxy :: Proxy r)++        parsers = readP_r `HCons` (hMap (ReadComponent True) rs :: HList bs)+++++ -- --------------------------------------------------------------------------  -- Extension -instance HRLabelSet (Tagged l v ': r) -    => HExtend (Tagged (l :: k) v) (Record r) where-  type HExtendR (Tagged l v) (Record r) = Record (Tagged l v ': r)+instance HRLabelSet (t ': r)+    => HExtend t (Record r) where+  type HExtendR t (Record r) = Record (t ': r)   f .*. (Record r) = mkRecord (HCons f r)  @@ -328,11 +529,11 @@  -- Concatenation -instance (HRLabelSet (HAppendList r1 r2), HAppend (HList r1) (HList r2))+instance (HRLabelSet (HAppendListR r1 r2), HAppend (HList r1) (HList r2))     => HAppend (Record r1) (Record r2) where   hAppend (Record r) (Record r') = mkRecord (hAppend r r') -type instance HAppendR (Record r1) (Record r2) = Record (HAppendList r1 r2)+type instance HAppendR (Record r1) (Record r2) = Record (HAppendListR r1 r2) -- --------------------------------------------------------------------------  -- Lookup@@ -348,7 +549,7 @@     hLookupByLabel:: Label l -> r -> v  {- alternative "straightforward" implementation-instance ( RecordLabels r ~ ls+instance ( LabelsOf r ~ ls          , HFind l ls n          , HLookupByHNat n r          , HLookupByHNatR n r ~ LVPair l v@@ -359,14 +560,55 @@         (LVPair v) = hLookupByHNat (proxy :: Proxy n) r -} +{- | a version of 'HasField' / 'hLookupByLabel' / '.!.' that+returns a default value when the label is not in the record: +>>> let r = x .=. "the x value" .*. emptyRecord -instance (HEq l l1 b, HasField' b l (Tagged l1 v1 ': r) v)+>>> hLookupByLabelM y r ()+()++>>> hLookupByLabelM x r ()+"the x value"++++-}+class HasFieldM (l :: k) r (v :: Maybe *) | l r -> v where+    hLookupByLabelM :: Label l+          -> r -- ^ Record (or Variant,TIP,TIC)+          -> t -- ^ default value+          -> DemoteMaybe t v++type family DemoteMaybe (d :: *) (v :: Maybe *) :: *+type instance DemoteMaybe d (Just a) = a+type instance DemoteMaybe d Nothing = d++class HasFieldM1 (b :: Maybe [*]) (l :: k) r v | b l r -> v where+    hLookupByLabelM1 :: Proxy b -> Label l -> r -> t -> DemoteMaybe t v++instance (HMemberM (Label l) (LabelsOf xs) b,+          HasFieldM1 b l (r xs) v)  => HasFieldM l (r xs) v where+    hLookupByLabelM = hLookupByLabelM1 (Proxy :: Proxy b)++instance HasFieldM1 Nothing l r Nothing where+    hLookupByLabelM1 _ _ _ t = t++instance HasField l r v => HasFieldM1 (Just b) l r (Just v) where+    hLookupByLabelM1 _ l r _t = hLookupByLabel l r++++instance (HEqK l l1 b, HasField' b l (Tagged l1 v1 ': r) v)     => HasField l (Record (Tagged l1 v1 ': r)) v where     hLookupByLabel l (Record r) =              hLookupByLabel' (Proxy::Proxy b) l r +-- | XXX+instance (t ~ Any, Fail (FieldNotFound l ())) => HasField l (Record '[]) t where+    hLookupByLabel _ _ = error "Data.HList.Record.HasField: Fail instances should not exist" + class HasField' (b::Bool) (l :: k) (r::[*]) v | b l r -> v where     hLookupByLabel':: Proxy b -> Label l -> HList r -> v @@ -417,11 +659,10 @@  -- Delete -hDeleteAtLabel :: forall l t t1 t2. -   (H2ProjectByLabels '[l] t t1 t2) =>-   Label l -> Record t -> Record t2-hDeleteAtLabel _ (Record r) = -  Record $ snd $ h2projectByLabels (Proxy::Proxy '[l]) r+instance (H2ProjectByLabels '[Label l] v t1 v')+      => HDeleteAtLabel Record l v v' where+  hDeleteAtLabel _ (Record r) =+    Record $ snd $ h2projectByLabels (Proxy::Proxy '[Label l]) r  infixl 2 .-. {-|@@ -446,8 +687,8 @@   >         .-. label1  -}-(.-.) :: (H2ProjectByLabels '[l] r _r' r') =>-    Record r -> Label l -> Record r'+(.-.) :: (HDeleteAtLabel r l xs xs') =>+    r xs -> Label l -> r xs' r .-. l =  hDeleteAtLabel l r  @@ -456,12 +697,54 @@ -- Update  -- | 'hUpdateAtLabel' @label value record@-hUpdateAtLabel :: forall (r :: [*]) (l :: k) (n::HNat) (v :: *). -  (HFind l (RecordLabels r) n, HUpdateAtHNat n (Tagged l v) r) =>-  Label l -> v -> Record r -> Record (HUpdateAtHNatR n (Tagged l v) r)-hUpdateAtLabel l v (Record r) = ++class+    HUpdateAtLabel record (l :: k) (v :: *) (r :: [*]) (r' :: [*])+          | l v r -> r', l r' -> v where+    hUpdateAtLabel :: SameLength r r' => Label l -> v -> record r -> record r'++instance (HUpdateAtLabel2 l v r r',+        HasField l (Record r') v) =>+        HUpdateAtLabel Record l v r r' where+    hUpdateAtLabel = hUpdateAtLabel2++{- alternative impl which reports a Fail constraint that is too long (the+one from HUpdateAtHNat) on ghc 7.10 RC1++instance (HasField l (Record r') v,+          HFindLabel l r n,+          HUpdateAtHNat n (Tagged l v) r,+          HUpdateAtHNatR n (Tagged l v) r ~ r',+          SameLength r r') =>+  HUpdateAtLabel Record l v r r' where+  hUpdateAtLabel l v (Record r) =     Record (hUpdateAtHNat (Proxy::Proxy n) (newLVPair l v) r)+-} +class HUpdateAtLabel2 (l :: k) (v :: *) (r :: [*]) (r' :: [*])+        | l r v -> r' where+    hUpdateAtLabel2 :: Label l -> v -> Record r -> Record r'++class HUpdateAtLabel1 (b :: Bool) (l :: k) (v :: *) (r :: [*]) (r' :: [*])+        | b l v r -> r' where+    hUpdateAtLabel1 :: Proxy b -> Label l -> v -> Record r -> Record r'++instance HUpdateAtLabel1 True l v (Tagged l e ': xs) (Tagged l v ': xs) where+    hUpdateAtLabel1 _b _l v (Record (e `HCons` xs)) = Record (e{ unTagged = v } `HCons` xs)++instance HUpdateAtLabel2 l v xs xs' => HUpdateAtLabel1 False l v (x ': xs) (x ': xs') where+    hUpdateAtLabel1 _b l v (Record (x `HCons` xs)) = case hUpdateAtLabel2 l v (Record xs) of+        Record xs' -> Record (x `HCons` xs')++instance (HEqK l l' b, HUpdateAtLabel1 b l v (Tagged l' e ': xs) xs')+    => HUpdateAtLabel2 l v (Tagged l' e ': xs) xs' where+    hUpdateAtLabel2 = hUpdateAtLabel1 (Proxy :: Proxy b)++-- | XXX+instance Fail (FieldNotFound l ()) => HUpdateAtLabel2 l v '[] '[] where+    hUpdateAtLabel2 _ _ r = r++ infixr 2 .@. {-| @@ -485,24 +768,58 @@   -- | @hProjectByLabels ls r@ returns @r@ with only the labels in @ls@ remaining-hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) => -	Proxy ls -> Record t -> Record a+hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) =>+        proxy ls -> Record t -> Record a hProjectByLabels ls (Record r) = mkRecord (fst $ h2projectByLabels ls r)  -- | See 'H2ProjectByLabels'-hProjectByLabels2 :: +hProjectByLabels2 ::     (H2ProjectByLabels ls t t1 t2, HRLabelSet t1, HRLabelSet t2) =>     Proxy ls -> Record t -> (Record t1, Record t2) hProjectByLabels2 ls (Record r) = (mkRecord rin, mkRecord rout)    where (rin,rout) = h2projectByLabels ls r +-- need to rearrange because the ordering in the result is determined by+-- the ordering in the original record, not the ordering in the proxy. In+-- other words,+--+-- > hProjectByLabels (Proxy :: Proxy ["x","y"]) r == hProjectByLabels (Proxy :: Proxy ["y","x"]) r+hProjectByLabels' r =+    let r' = hRearrange' (hProjectByLabels (labelsOf r') r)+    in r'++++{- | A helper to make the Proxy needed by hProjectByLabels,+and similar functions which accept a list of kind [*].++For example:++@(rin,rout) = 'hProjectByLabels2' (Proxy :: Labels ["x","y"]) r@++behaves like++> rin = r .!. (Label :: Label "x") .*.+>       r .!. (Label :: Label "y") .*.+>       emptyRecord+>+> rout = r .-. (Label :: Label "x") .-. (Label :: Label "y")++-}+type family Labels (xs :: [k]) :: *+type instance Labels xs = Proxy (Labels1 xs)++type family Labels1 (xs :: [k]) :: [*]+type instance Labels1 '[] = '[]+type instance Labels1 (x ': xs) = Label x ': Labels1 xs+ -- | /Invariant/: -- --  > r === rin `disjoint-union` rout --  > labels rin === ls --  >     where (rin,rout) = hProjectByLabels ls r-class H2ProjectByLabels (ls::[k]) r rin rout | ls r -> rin rout where-    h2projectByLabels :: Proxy ls -> HList r -> (HList rin,HList rout)+class H2ProjectByLabels (ls::[*]) r rin rout | ls r -> rin rout where+    h2projectByLabels :: proxy ls -> HList r -> (HList rin,HList rout)  instance H2ProjectByLabels '[] r '[] r where     h2projectByLabels _ r = (HNil,r)@@ -510,21 +827,23 @@ instance H2ProjectByLabels (l ': ls) '[] '[] '[] where     h2projectByLabels _ _ = (HNil,HNil) -instance (HMemberM l1 ((l::k) ': ls) (b :: Maybe [k]),+instance (HMemberM (Label l1) ((l :: *) ': ls) (b :: Maybe [*]),           H2ProjectByLabels' b (l ': ls) (Tagged l1 v1 ': r1) rin rout)     => H2ProjectByLabels (l ': ls) (Tagged l1 v1 ': r1) rin rout where     h2projectByLabels = h2projectByLabels' (Proxy::Proxy b) -class H2ProjectByLabels' (b::Maybe [k]) (ls::[k]) r rin rout +class H2ProjectByLabels' (b::Maybe [*]) (ls::[*]) r rin rout                          | b ls r -> rin rout where-    h2projectByLabels' :: Proxy b -> Proxy ls -> -				     HList r -> (HList rin,HList rout)+    h2projectByLabels' :: Proxy b -> proxy ls ->+                                     HList r -> (HList rin,HList rout)  instance H2ProjectByLabels ls1 r rin rout =>     H2ProjectByLabels' ('Just ls1) ls (f ': r) (f ': rin) rout where     h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout)         where (rin,rout) = h2projectByLabels (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)@@ -546,12 +865,11 @@  -- -------------------------------------------------------------------------- +type HTPupdateAtLabel record l v r = (HUpdateAtLabel record l v r r, SameLength' r r)+ -- | A variation on 'hUpdateAtLabel': type-preserving update.+hTPupdateAtLabel :: HTPupdateAtLabel record l v r => Label l -> v -> record r -> record r hTPupdateAtLabel l v r = hUpdateAtLabel l v r- where-   _te :: a -> a -> ()-   _te _ _ = ()-   _ = _te v (hLookupByLabel l r)  {- ^ @@ -574,40 +892,41 @@ -- -------------------------------------------------------------------------- -- | Subtyping for records -instance H2ProjectByLabels (RecordLabels r2) r1 r2 rout+instance H2ProjectByLabels (LabelsOf r2) r1 r2 rout     => SubType (Record r1) (Record r2)  +type HMemberLabel l r b = HMember l (UnLabel l (LabelsOf r)) b+ -- --------------------------------------------------------------------------  -- Left Union -class  HLeftUnion r r' r'' | r r' -> r''- where hLeftUnion :: Record r -> Record r' -> Record r''+class HDeleteLabels ks r r' | ks r -> r'+ where hDeleteLabels :: proxy (ks :: [*]) -- ^ as provided by labelsOf+          -> Record r -> Record r' -instance HLeftUnion r '[] r- where   hLeftUnion r _ = r+instance (HMember (Label l) ks b,+          HCond b (Record r2) (Record (Tagged l v ': r2)) (Record r3),+          HDeleteLabels ks r1 r2) =>+    HDeleteLabels ks (Tagged l v ': r1) r3 where+      hDeleteLabels ks (Record (HCons lv r1)) =+          case hDeleteLabels ks (Record r1) of+             Record r2 -> hCond (Proxy :: Proxy b)+                  (Record r2)+                  (Record (HCons lv r2))+instance HDeleteLabels ks '[] '[] where+    hDeleteLabels _ _ = emptyRecord -instance ( RecordLabels r ~ ls-         , HMember l ls b-         , HLeftUnionBool b r (Tagged l v) r'''-         , HLeftUnion r''' r' r''-         )-           => HLeftUnion r (Tagged l v ': r') r''-  where-   hLeftUnion r (Record (HCons f r')) = r''-    where-     r'''    = hLeftUnionBool (Proxy :: Proxy b) r f-     r''     = hLeftUnion (r''' :: Record r''') (Record r' :: Record r') -class  HLeftUnionBool (b :: Bool) r f r' | b r f -> r'- where hLeftUnionBool :: Proxy b -> Record r -> f -> Record r'+class  HLeftUnion r r' r'' | r r' -> r''+ where hLeftUnion :: Record r -> Record r' -> Record r'' -instance HLeftUnionBool True r f r-   where hLeftUnionBool _ r _  = r+instance (HDeleteLabels (LabelsOf l) r r',+         HAppend (Record l) (Record r'),+         HAppendR (Record l) (Record r') ~ (Record lr)) => HLeftUnion l r lr+ where  hLeftUnion l r = l `hAppend` hDeleteLabels (labelsOf l) r -instance HLeftUnionBool False r f (f ': r)-   where hLeftUnionBool _ (Record r) f = Record (HCons f r)  infixl 1 .<++. {-|@@ -651,11 +970,10 @@ class UnionSymRec r1 r2 ru | r1 r2 -> ru where     unionSR :: Record r1 -> Record r2 -> (Record ru, Record ru) -instance UnionSymRec r1 '[] r1 where+instance (r1 ~ r1') => UnionSymRec r1 '[] r1' where     unionSR r1 _ = (r1, r1) -instance ( RecordLabels r1 ~ ls-         , HMember l ls b+instance ( HMemberLabel l r1 b          , UnionSymRec' b r1 (Tagged l v) r2' ru          )     => UnionSymRec r1 (Tagged l v ': r2') ru@@ -668,29 +986,25 @@   -{- -- | Field f2 is already in r1, so it will be in the union of r1 -- with the rest of r2. -- -- To inject (HCons f2 r2) in that union, we should replace the -- field f2--} instance (UnionSymRec r1 r2' ru,-          HasField l2 (Record ru) v2,-          HUpdateAtHNat n (Tagged l2 v2) ru,-          ru ~ HUpdateAtHNatR n (Tagged l2 v2) ru,-          RecordLabels ru ~ ls,-          f2 ~ Tagged l2 v2,-          HFind l2 ls n)+          HTPupdateAtLabel Record l2 v2 ru,+          f2 ~ Tagged l2 v2)     => UnionSymRec' True r1 f2 r2' ru where     unionSR' _ r1 (Tagged v2) r2' =        case unionSR r1 r2'         of (ul,ur) -> (ul, hTPupdateAtLabel (Label :: Label l2) v2 ur)  + instance (UnionSymRec r1 r2' ru,           HExtend f2 (Record ru),-          HExtendR f2 (Record ru) ~ Record f2ru)+          Record f2ru ~ HExtendR f2 (Record ru)+        )     => UnionSymRec' False r1 f2 r2' f2ru where     unionSR' _ r1 f2 r2' = (ul', ur')        where (ul,ur) = unionSR r1 r2'@@ -699,55 +1013,331 @@  -- -------------------------------------------------------------------------- -- | Rearranges a record by labels. Returns the record r, rearranged such that--- the labels are in the order given by ls. (recordLabels r) must be a+-- the labels are in the order given by ls. (LabelsOf r) must be a -- permutation of ls.-hRearrange :: (HLabelSet ls, HRearrange ls r (HList r')) => Proxy ls -> Record r -> Record r'+hRearrange :: (HLabelSet ls, HRearrange ls r r') => Proxy ls -> Record r -> Record r' hRearrange ls (Record r) = Record (hRearrange2 ls r) +{- | 'hRearrange'' is 'hRearrange' where ordering specified by the Proxy+argument is determined by the result type.++With built-in haskell records, these @e1@ and @e2@ have the same type:++> data R = R { x, y :: Int }+> e1 = R{ x = 1, y = 2}+> e2 = R{ y = 2, x = 1}++'hRearrange'' can be used to allow either ordering to be accepted:++> h1, h2 :: Record [ Tagged "x" Int, Tagged "y" Int ]+> h1 = hRearrange' $+>     x .=. 1 .*.+>     y .=. 2 .*.+>     emptyRecord+>+> h2 = hRearrange' $+>     y .=. 2 .*.+>     x .=. 1 .*.+>     emptyRecord++-}+hRearrange' r =+    let r' = hRearrange (labelsOf r') r+    in r'+++class Rearranged r s t a b where+    -- @Iso (r s) (r t) (r a) (r b)@+    rearranged :: (Profunctor p, Functor f) => r a `p` f (r b) -> r s `p` f (r t)+++{- | @Iso (Record s) (Record t) (Record a) (Record b)@++where @s@ is a permutation of @a@, @b@ is a permutation of @t@.+In practice 'sameLabels' and 'sameLength' are likely needed on both+sides of @rearranged@, to avoid ambiguous types.++An alternative implementation:++> rearranged x = iso hRearrange' hRearrange' x++-}+instance (la ~ LabelsOf a, lt ~ LabelsOf t,+          HRearrange la s a,+          HRearrange lt b t,+          HLabelSet la,+          HLabelSet lt)+  => Rearranged Record s t a b where+    rearranged = iso (hRearrange (Proxy :: Proxy la))+                     (hRearrange (Proxy :: Proxy lt))++{- | @Iso' (r s) (r a)@++where @s@ is a permutation of @a@ -}+rearranged' x = isSimple rearranged x+ -- | Helper class for 'hRearrange'-class HRearrange ls r r' where-    hRearrange2 :: Proxy ls -> HList r -> r'+class (HRearrange3 ls r r', LabelsOf r' ~ ls,+       SameLength ls r, SameLength r r')+      => HRearrange (ls :: [*]) r r' | ls r -> r', r' -> ls where+    hRearrange2 :: proxy ls -> HList r -> HList r' -instance (HList '[] ~ r) => HRearrange '[] '[] r where-   hRearrange2 _ _ = HNil +instance (HRearrange3 ls r r', LabelsOf r' ~ ls,+        SameLength ls r, SameLength r r') => HRearrange ls r r' where+    hRearrange2 = hRearrange3++-- | same as HRearrange, except no backwards FD+class HRearrange3 (ls :: [*]) r r' | ls r -> r' where+    hRearrange3 :: proxy ls -> HList r -> HList r'++instance HRearrange3 '[] '[] '[] where+   hRearrange3 _ _ = HNil+ instance (H2ProjectByLabels '[l] r rin rout,-          HRearrange' l ls rin rout (HList r'),-          r'' ~ HList r') =>-        HRearrange (l ': ls) r r'' where-   hRearrange2 _ r = hRearrange2' (Proxy :: Proxy l) (Proxy :: Proxy ls) rin rout+          HRearrange4 l ls rin rout r',+          l ~ Label ll) =>+        HRearrange3 (l ': ls) r r' where+   hRearrange3 _ r = hRearrange4 (Proxy :: Proxy l) (Proxy :: Proxy ls) rin rout       where (rin, rout) = h2projectByLabels (Proxy :: Proxy '[l]) r   -- | Helper class 2 for 'hRearrange'-class HRearrange' l ls rin rout r' where-    hRearrange2' :: Proxy l -> Proxy ls -> HList rin -> HList rout -> r'- -instance (HRearrange ls rout (HList r'),-         r'' ~ HList (Tagged l v ': r')) =>-        HRearrange' l ls '[Tagged l v] rout r'' where-   hRearrange2' _ ls (HCons lv@(Tagged v) _HNil) rout-        = HCons (Tagged v `asTypeOf` lv) (hRearrange2 ls rout)+class HRearrange4 (l :: *) (ls :: [*]) rin rout r' | l ls rin rout -> r' where+    hRearrange4 :: proxy l -> Proxy ls -> HList rin -> HList rout -> HList r' -data ExtraField l = ExtraField-data FieldNotFound l = FieldNotFound+instance (HRearrange3 ls rout r',+         r'' ~ (Tagged l v ': r'),+         ll ~ Label l) =>+        HRearrange4 ll ls '[Tagged l v] rout r'' where+   hRearrange4 _ ls (HCons lv@(Tagged v) _HNil) rout+        = HCons (Tagged v `asTypeOf` lv) (hRearrange3 ls rout) --- | For improved error messages-instance Fail (FieldNotFound l) => -        HRearrange' l ls '[] rout (FieldNotFound l) where-   hRearrange2' _ _ _ _ = FieldNotFound+-- | For improved error messages. XXX FieldNotFound+instance Fail (FieldNotFound l ()) =>+        HRearrange4 l ls '[] rout '[] where+   hRearrange4 _ _ _ _ = error "Fail has no instances"  -- | For improved error messages-instance Fail (ExtraField l) => -          HRearrange '[] (Tagged l v ': a) (ExtraField l) where-   hRearrange2 _ _ = ExtraField+instance Fail (ExtraField l) =>+          HRearrange3 '[] (Tagged l v ': a) '[] where+   hRearrange3 _ _ = error "Fail has no instances"   -- -------------------------------------------------------------------------- -- $lens--- Lens-based setters/getters are popular.+-- Lens-based setters/getters are popular. hLens packages up+-- 'hUpdateAtLabel' and 'hLookupByLabel'. ----- This is a provisional method to make a @Lens (Record s) (Record t) a b@,--- out of a 'Label' @x@. Refer to @examples/lens.hs@ for an example.-hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab)) +-- Refer to @examples/lens.hs@ and @examples/labelable.hs@ for examples. +-- | constraints needed to implement 'HLens'+type HLensCxt x r s t a b =+    (HasField x (r s) a,+     HUpdateAtLabel r x b s t,+     HasField x (r t) b,+     HUpdateAtLabel r x a t s,+     SameLength s t,+     SameLabels s t)++class HLensCxt x r s t a b => HLens x r s t a b+        | x s b -> t, x t a -> s, -- need to repeat fundeps implied by HLensCxt+          x s -> a, x t -> b where+    -- | @hLens :: Label x -> Lens (r s) (r t) a b@+    hLens :: Label x -> (forall f. Functor f => (a -> f b) -> (r s -> f (r t)))++instance HLensCxt r x s t a b => HLens r x s t a b where+  hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab))+++{- | map over the values of a record. This is a shortcut for++  > \ f (Record a) -> Record (hMap (HFmap f) a)++[@Example@]++suppose we have a function that should be applied to every element+of a record:++>>> let circSucc_ x | x == maxBound = minBound | otherwise = succ x++>>> :t circSucc_+circSucc_ :: (Bounded a, Enum a, Eq a) => a -> a++Use a shortcut ('Fun') to create a value that has an appropriate 'ApplyAB' instance:++>>> let circSucc = Fun circSucc_ :: Fun '[Eq,Enum,Bounded] '()++Confirm that we got Fun right:++>>> :t applyAB circSucc+applyAB circSucc :: (Bounded b, Enum b, Eq b) => b -> b++>>> applyAB circSucc True+False++define the actual record:++>>> let r = x .=. 'a' .*. y .=. False .*. emptyRecord+>>> r+Record{x='a',y=False}++>>> hMapR circSucc r+Record{x='b',y=True}++-}+hMapR f r = applyAB (HMapR f) r++newtype HMapR f = HMapR f++instance (HMapCxt Record f x y, rx ~ Record x, ry ~ Record y)+      => ApplyAB (HMapR f) rx ry where+        applyAB (HMapR f) = hMapAux f++instance HMapAux HList (HFmap f) x y =>+    HMapAux Record f x y where+      hMapAux f (Record x) = Record (hMapAux (HFmap f) x)++++-- --------------------------------------------------------------------------+-- | This instance allows creating a Record with+--+-- @hBuild 3 'a' :: Record '[Tagged "x" Int, Tagged "y" Char]@+instance (HReverse l lRev,+         HMapTaggedFn lRev l') => HBuild' l (Record l') where+  hBuild' l = hMapTaggedFn (hReverse l)++-- | serves the same purpose as 'hEnd'+hEndR :: Record a -> Record a+hEndR = id+++-- | see 'hEndP'+instance (HRevAppR l '[] ~ lRev,+          HExtendRs lRev (Proxy ('[] :: [*])) ~ Proxy l1,+          l' ~ l1) => HBuild' l (Proxy l') where+  hBuild' _ = Proxy++{- | @'hEndP' $ 'hBuild' label1 label2@++is one way to make a Proxy of labels (for use with 'asLabelsOf'+for example). Another way is++@label1 .*. label2 .*. 'emptyProxy'@++-}+hEndP :: Proxy (xs :: [k]) -> Proxy xs+hEndP = id++type family HExtendRs (ls :: [*]) (z :: k) :: k+type instance HExtendRs (l ': ls) z = HExtendR l (HExtendRs ls z)+type instance HExtendRs '[] z = z++-- --------------------------------------------------------------------------++{- |++>>> let x :: Record '[Tagged "x" Int]; x = undefined+>>> let y :: Record '[Tagged "x" Char]; y = undefined+>>> :t hZip x y+hZip x y :: Record '[Tagged "x" (Int, Char)]++-}+instance (HZipRecord x y xy, SameLengths [x,y,xy])+      => HZip Record x y xy where+    hZip = hZipRecord++instance (HZipRecord x y xy, SameLengths [x,y,xy])+      => HUnzip Record x y xy where+    hUnzip = hUnzipRecord+++#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+the list of labels does not have to include Label+(as in @ts'@)++>>> let ts = Proxy :: Proxy ["x","y"]+>>> let ts' = Proxy :: Proxy [Label "x",Label "y"]+>>> let vs = Proxy :: Proxy [Int,Char]++>>> :t zipTagged ts Proxy+zipTagged ts Proxy :: Proxy '[Tagged "x" y, Tagged "y" y1]++>>> :t zipTagged ts vs+zipTagged ts vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]+++And and the case when hZip does the same thing:++>>> :t zipTagged ts' vs+zipTagged ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]++>>> :t hZip ts' vs+hZip ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]++-}+zipTagged :: (MapLabel ts ~ lts,+              HZip Proxy lts vs tvs)+      => Proxy ts -> proxy vs -> Proxy tvs+zipTagged _ _ = Proxy+#endif++++class HZipRecord x y xy | x y -> xy, xy -> x y where+    hZipRecord :: Record x -> Record y -> Record xy+    hUnzipRecord :: Record xy -> (Record x,Record y)+++instance HZipRecord '[] '[] '[] where+    hZipRecord _ _ = emptyRecord+    hUnzipRecord _ = (emptyRecord, emptyRecord)++instance HZipRecord as bs abss+       => HZipRecord (Tagged x a ': as) (Tagged x b ': bs) (Tagged x (a,b) ': abss) where+    hZipRecord (Record (Tagged a `HCons` as)) (Record (Tagged b `HCons` bs)) =+        let Record abss = hZipRecord (Record as) (Record bs)+        in Record (Tagged (a,b) `HCons` abss)+    hUnzipRecord (Record (Tagged (a,b) `HCons` abss)) =+        let (Record as, Record bs) = hUnzipRecord (Record abss)+        in (Record (Tagged a `HCons` as), Record (Tagged b `HCons` bs))+++-- | instead of explicit recursion above, we could define HZipRecord in+-- terms of 'HZipList'. While all types are inferred, this implementation+-- is probably slower, so explicit recursion is used in the 'HZip' 'Record'+-- instance.+hZipRecord2 x y = hMapTaggedFn (hZipList (recordValues x) (recordValues y))+        `asLabelsOf` x `asLabelsOf` y++hUnzipRecord2 xy = let (x,y) = hUnzipList (recordValues xy)+                 in (hMapTaggedFn x `asLabelsOf` xy, hMapTaggedFn y `asLabelsOf` xy)+++{- | similar to 'asTypeOf':++>>> let s0 = Proxy :: Proxy '["x", "y"]+>>> let s1 = Proxy :: Proxy '[Label "x", Label "y"]+>>> let s2 = Proxy :: Proxy '[Tagged "x" Int, Tagged "y" Char]++>>> let f0 r = () where _ = r `asLabelsOf` s0+>>> let f1 r = () where _ = r `asLabelsOf` s1+>>> let f2 r = () where _ = r `asLabelsOf` s2++>>> :t f0+f0 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++>>> :t f1+f1 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++>>> :t f2+f2 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++-}+asLabelsOf :: (HAllTaggedLV x, SameLabels x y, SameLength x y) => r x -> s y -> r x+asLabelsOf = const
Data/HList/RecordPuns.hs view
@@ -36,16 +36,18 @@  [@nesting@] -Nesting is supported. The idea is that variables inside-@{ }@ are in another record. More concretely:+Nesting is supported. Variables inside+@{ }@ and @( )@ are one level deeper, like the built-in syntax.+Furthermore the outer @{ }@ can be left out because @[pun|{x}|]@ is more+cluttered than @[pun|x|]@.+More concretely the pattern: -> [pun| ab@{ a b } y z c{d} |] -as a pattern, it will bindings from an original record @x@,-if you interpret (.) as a left-associative field lookup (as it-is in other languages):+> let [pun| ab@{ a b } y z c{d} |] = x -> let ab = xab+is short for:++> let ab = x.ab >     a = x.ab.a >     b = x.ab.b >     y = x.y@@ -53,49 +55,80 @@ >     -- c is not bound >     d = x.c.d -as an expression, it creates a new record which needs the variables-@ab a b y z d@ in-scope. @ab@ needs to be a record, and if it has-fields called @a@ or @b@ they are overridden by the values of @a@ and @b@-which are in scope.+Where here `.` is a left-associative field lookup (as it is in other languages). -@( )@ parens mean the same thing as @{ }@, except the pattern match-restricts the fields in the record supplied to be exactly the ones-provided. In other words+The pun quasiquoter can also be used in an expression context: -> [pun| (x y) |] = list+> let mkX ab a b y z d = [pun| ab@{ a b } y z c{d} |]+>     x = mkX ab b y z d++Here `mkX` includes @ab a b y z d@. @ab@ needs to be a record, and if it has+fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ (via+'hLeftUnion' = '.<++.') . In other words,++> let mkX ab_ a b y z d = let ab = [pun| a b |] .<++. ab_+>                               in [pun| ab y z c{d} |]++For patterns, any order and additional fields are allowed if @{ }@ is used,+just as in built-in record syntax. But it is often necessary to restrict the+order and number of fields, such as if the record is a 'hRearrange' of a 'hLeftUnion'.+So use @( )@ instead:++> let [pun| (x _ y{}) |] = list > -- desugars to something like:-> Record (HCons (Tagged x :: Tagged "x" s1)->              (HCons (Tagged x :: Tagged "y" s2)->               HNil)) = list+> Record ((Tagged x :: Tagged "x" s1) `HCons`+>         (Tagged _ :: Tagged t   s2) `HCons`+>         (Tagged _ :: Tagged "y" s3) `HCons`+>          HNil) = list -Where the @s1@ and @s2@ are allowed to fit whatever is in the HList.+Note that this also introduces the familiar wild card pattern (@_@),+and shows again how to ensure a label is present but not bind a variable+to it. -See also @examples/pun.hs@.+For comparison, here are three equivalent ways to define variables `x` and `y`++> let [pun| x y{} |] = r+> let [pun|{ x y{} }|] = r -- or this+> let x = r .!. (Label :: Label "x")+>     y = constrainType (r .!. (Label :: Label "y"))+>     constrainType :: Record t -> Record t+>     constrainType = id++See also @examples/pun.hs@. In @{}@ patterns, @pun@ can work with+'Variant' too.+ -}  --- | requires the use of "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@)+-- | requires labels to be promoted strings (kind Symbol), as provided by+-- "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@),+-- or "Data.HList.Labelable" pun :: QuasiQuoter pun = QuasiQuoter {-    quotePat = mp . parseRec,-    quoteExp = me . parseRec,+    quotePat = suppressWarning mp . parseRec,+    quoteExp = suppressWarning me . parseRec,     quoteDec  = error "Data.HList.RecordPuns.quoteDec",     quoteType = error "Data.HList.RecordPuns.quoteType"  }  --- like  \x -> (x .!. x1, x .!. x2)+-- | the warning about @implicit {} added@ doesn't+-- make sense at top level (but it does if you say+-- have  [pun| x @ y |]+suppressWarning f (V a) = f (C [V a])+suppressWarning f x = f x++-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2),+-- where x1 = Label :: Label "x1" extracts xs = do     record <- newName "record"-    lamE [varP record]-        (tupE+    -- to fix #5 I could comment out the ensureLength below+    lamE [varP record] $ tupE             [ [| $(varE record) .!. $label  |]                 | x <- xs,-                let label = [| Label :: Label $(litT (strTyLit x)) |]-                ])--mkExp :: [String] -> ExpQ-mkExp xs = foldr (\x acc -> [| $(mkPair x (dyn x)) .*. $acc |]) [| emptyRecord |] xs+                let label = [| Label :: Label $(litT (strTyLit x)) |],+                x /= "_"+                ]  mkPair :: String -> ExpQ -> ExpQ mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |]@@ -119,21 +152,22 @@                         show (map ppTree inp)  mp :: Tree -> PatQ-mp (C as) = case unzip (mps as) of-    (a, b) -> viewP (extracts a) (tupP b)+mp (C as) =+    let extractPats = mps as+        tupleP = tupP [ p | (binding, p) <- extractPats, binding /= "_" ]+    in viewP (extracts (map fst extractPats)) tupleP --- use of prime here (non GADT version) because it is better for type--- inference. See commentary surrounding HCons' in Data.HList.HList+ mp (D as) = conP 'Record-  [viewP (varE 'prime) -- nicer to have [p| prime -> $( ... ) |],-                       -- but ghc-7.6 rejects that over types-   (foldr ( \ (n,p) xs -> conP 'HCons'-                [viewP [| \x -> x `asTypeOf`-                            (undefined :: Tagged $(litT (strTyLit n)) t) |]-                (conP 'Tagged [p]),+  [foldr ( \ (n,p) xs -> conP 'HCons+                [ let ty+                          | n == "_"  = [| undefined :: Tagged anyLabel t |]+                          | otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |]+                  in viewP [| \x -> x `asTypeOf` $ty |]+                      (conP 'Tagged [p]),                 xs])-          (conP 'HNil' [])-          (mps as))]+          (conP 'HNil [])+          (mps as)] mp a = do     reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a     mp (C [a])@@ -142,6 +176,7 @@ mps (V a : V "@" : b : c) = (a, asP (mkName a) (mp b)) :  mps c mps (V a : C b : c) = (a, mp (C b)) : mps c mps (V a : D b : c) = (a, mp (D b)) : mps c+mps (V "_" : b) = ("_", wildP) : mps b mps (V a : b) = (a, varP (mkName a)) : mps b mps [] = [] mps inp = error $ "Data.HList.RecordPuns.mps: cannot translate remaining pattern:" ++
+ Data/HList/RecordU.hs view
@@ -0,0 +1,434 @@+{- | Description: records where elements are stored in unboxed arrays++The public interface is exported from <Data-HList-CommonMain.html#t:RecordU RecordU>++-}+module Data.HList.RecordU where++import Data.Array.Unboxed+import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.HList++import Data.HList.HArray+import LensDefs++import Data.HList.Labelable++import Unsafe.Coerce++-- * Type definitions+-- ** RecordUS++{- | 'RecordUS' is stored as a 'HList' of 'RecordU' +to allow the 'RecordUS' to contain elements of different+types, so long all of the types can be put into an unboxed+array ('UArray').++It is advantageous (at least space-wise) to sort the record to keep+elements with the same types elements adjacent. See 'SortForRecordUS'+for more details.  -}+newtype RecordUS (x :: [*]) =+    RecordUS Any -- ^ Any here is the @HList u@+                 -- given @'RecordUSCxt' x u@++-- | connect the unpacked @x@ representation with the+-- corresponding list of RecordU @u@ representation.+class RecordUSCxt (x :: [*]) (u :: [*]) | x -> u, u -> x where+  {- | @O(1)@ should be possible to implement this without+  unsafeCoerce, but we want to hide the @u@ parameter _and_+  keep the RecordUSCxt as a class (instead of a type+  family) because of 'HEq'. In some cases it is possible+  to have instances that do not actually respect the functional+  dependency, but this should be safe if the check is not+  disabled (by using @-XDysfunctionalDependencies@+  <https://phabricator.haskell.org/D69>, or ghc-7.6) -}+  recordUSToHList :: RecordUS x -> HList u+  recordUSToHList (RecordUS x) = unsafeCoerce x++  -- | @O(1)@ should be possible to implement this without+  -- unsafeCoerce+  hListToRecordUS :: HList u -> RecordUS x+  hListToRecordUS x = RecordUS (unsafeCoerce x)++-- | the only instance+instance (HGroupBy EqTagValue x g, HMapUnboxF g u) => RecordUSCxt x u++data EqTagValue+instance HEqByFn EqTagValue+instance (txv ~ Tagged x v,+          tyw ~ Tagged y w,+          HEq v w b) => HEqBy EqTagValue txv tyw b++-- | proof that @'hMap' 'UnboxF' :: r xs -> r us@ can determine+-- @xs@ from @us@ and @us@ from @xs@+class HMapUnboxF (xs :: [*]) (us :: [*]) | xs -> us, us -> xs+instance HMapUnboxF '[] '[]+instance HMapUnboxF xs us => HMapUnboxF (HList x ': xs) (RecordU x ': us)+++instance (RecordUSCxt x u, Show (HList u)) => Show (RecordUS x) where+    showsPrec n r = ("RecordUS " ++) . showsPrec n (recordUSToHList r)++-- ** RecordU++{- | A type which behaves similarly to 'Record', except+all elements must fit in the same 'UArray'. A consequence of+this is that @RecordU@ has the following properties:++* it is strict in the element types++* it cannot do type-changing updates of 'RecordU', except if+  the function applies to all elements++* it probably is slower to update the very first elements+  of the 'RecordU'++The benefit is that lookups should be faster and records+should take up less space. However benchmarks done with+a slow 'HNat2Integral' do not suggest that RecordU is+faster than Record.+-}+newtype RecordU l = RecordU (UArray Int (GetElemTy l))++type family GetElemTy (x :: [*]) :: *+type instance GetElemTy (Tagged label v ': rest) = v++deriving instance (Show (UArray Int (GetElemTy l))) => Show (RecordU l)+deriving instance (Read (UArray Int (GetElemTy l))) => Read (RecordU l)+deriving instance (Eq  (UArray Int (GetElemTy l))) => Eq  (RecordU l)+deriving instance (Ord (UArray Int (GetElemTy l))) => Ord (RecordU l)++{- | Reorders a 'Record' such that the 'RecordUS' made from it takes up+less space++'Bad' has alternating Double and Int fields++>>> bad+Record{x=1.0,i=2,y=3.0,j=4}++4 arrays containing one element each are needed when this+Record is stored as a RecordUS++>>> recordToRecordUS bad+RecordUS H[RecordU (array (0,0) [(0,1.0)]),RecordU (array (0,0) [(0,2)]),RecordU (array (0,0) [(0,3.0)]),RecordU (array (0,0) [(0,4)])]++It is possible to sort the record++>>> sortForRecordUS bad+Record{x=1.0,y=3.0,i=2,j=4}++This allows the same content to be stored in+two unboxed arrays++>>> recordToRecordUS (sortForRecordUS bad)+RecordUS H[RecordU (array (0,1) [(0,1.0),(1,3.0)]),RecordU (array (0,1) [(0,2),(1,4)])]++-}+class SortForRecordUS x x' | x -> x' where+    sortForRecordUS :: Record x -> Record x'++instance SortForRecordUS '[] '[] where+    sortForRecordUS = id++instance (HPartitionEq EqTagValue x (x ': xs) xi xo,+          SortForRecordUS xo xo',+          sorted ~ HAppendListR xi xo',+          HAppendList xi xo') =>+  SortForRecordUS (x ': xs) sorted where+  sortForRecordUS (Record xs) = Record (hAppendList xi xo')+    where+      f  = Proxy :: Proxy EqTagValue+      x1 = Proxy :: Proxy x+      (xi,xo) = hPartitionEq f x1 xs+      Record xo' = sortForRecordUS (Record xo)++-------------------------------------------------------------- +-- * Lookup++-- | works expected. See examples attached to 'bad'.+instance (HFindLabel l r n,+          HLookupByHNatUS n u (Tagged l v),+          HasField l (Record r) v,+          RecordUSCxt r u) =>+  HasField l (RecordUS r) v where+  hLookupByLabel _ u = case hLookupByHNatUS n (recordUSToHList u) of Tagged v -> v+    where n = Proxy :: Proxy n++class HLookupByHNatUS (n :: HNat) (us :: [*]) (e :: *) | n us -> e where+  hLookupByHNatUS :: Proxy n -> HList us -> e++class HLookupByHNatUS1 (r :: Either HNat HNat) (n :: HNat) (u :: [*]) (us :: [*]) (e :: *)+        | r n u us -> e where+  hLookupByHNatUS1 :: Proxy r -> Proxy n -> RecordU u -> HList us -> e++instance (r ~ HSubtract (HLength u) n,+          RecordU u ~ ru,+          HLookupByHNatUS1 r n u us e) =>+  HLookupByHNatUS n (ru ': us) e where+  hLookupByHNatUS n (HCons u us) = hLookupByHNatUS1 (Proxy :: Proxy r) n u us++instance (HNat2Integral n,+         HLookupByHNatR n u ~ le,+         le ~ Tagged l e,+         IArray UArray e,+         e ~ GetElemTy u) => HLookupByHNatUS1 (Left t) n u us le where+  hLookupByHNatUS1 _ n (RecordU u) _us = Tagged (u ! hNat2Integral n)++instance HLookupByHNatUS t us e => HLookupByHNatUS1 (Right t) n u us e where+  hLookupByHNatUS1 _ _ _ = hLookupByHNatUS (Proxy :: Proxy t)++-- | @HSubtract a b@ is @Left (a-b)@, @Right (b-a)@ or @Right HZero@+type family HSubtract (n1 :: HNat) (n2 :: HNat) :: Either HNat HNat++type instance HSubtract HZero HZero = Right HZero+type instance HSubtract (HSucc x) (HSucc y) = HSubtract x y+type instance HSubtract HZero (HSucc y) = Right (HSucc y)+type instance HSubtract (HSucc y) HZero = Left (HSucc y)+++++-------------------------------------------------------------- +-- * Conversion of RecordUS++-- ** with the actual representation++-- | @Iso (HList s) (HList t) (RecordUS a) (RecordUS b)@+recordUS r = iso hListToRecordUS recordUSToHList r++{- | @Iso (HList s) (RecordUS a)@++@s@ is a HList of 'RecordU' while @a :: [*]@+is list of @Tagged label value@++-}+recordUS' r = isSimple recordUS r++-- ** with 'Record'++-- | @view unboxedS@ or @^. unboxedS@ are preferred+recordToRecordUS :: forall x g u.+   (HMapCxt HList UnboxF g u,+    HMapUnboxF g u,+    HGroupBy EqTagValue x g,+    RecordUSCxt x u)+   => Record x -> RecordUS x+recordToRecordUS (Record x) = hListToRecordUS u+  where+    u :: HList u+    u = hMap UnboxF g ++    g :: HList g+    g = hGroupBy (Proxy :: Proxy EqTagValue) x++-- | @^. from unboxedS@ is preferred+recordUSToRecord :: forall u g x.+  (HConcatFD g x,+   HMapCxt HList BoxF u g,+   HMapUnboxF g u,+   RecordUSCxt x u+  ) => RecordUS x -> Record x+recordUSToRecord rus = Record (hConcatFD g)+  where+    g :: HList g+    g = hMap BoxF (recordUSToHList rus)++-- | @Iso (Record x) (Record y) (RecordUS x) (RecordUS y)@+unboxedS r = iso recordToRecordUS recordUSToRecord r++-- | @Iso' (Record x) (RecordUS x)@+unboxedS' r = isSimple unboxedS r++++-- | all elements of the list have the same type+class ElemTyEq (xs :: [*])++instance + (t1v ~ Tagged t1 v,+  t2v ~ Tagged t2 v,  +  ElemTyEq (tv2 ': rest)) =>+  ElemTyEq (tv1 ': tv2 ': rest)++instance t1v ~ Tagged t v => ElemTyEq (t1v ': rest)+instance ElemTyEq '[]+++instance (IArray UArray v,+          v ~ GetElemTy ls,+          HFindLabel l ls n,+          HNat2Integral n)+    => HasField l (RecordU ls) v where+  hLookupByLabel _ (RecordU ls) = ls ! hNat2Integral (Proxy :: Proxy n)+++instance (r ~ r',+          v ~ GetElemTy r,+          HFindLabel l r n,+          HNat2Integral n,+          IArray UArray v,+          HasField l (Record r') v)+    => HUpdateAtLabel RecordU l v r r' where+  hUpdateAtLabel _ v (RecordU r) = RecordU (r // [(hNat2Integral (Proxy :: Proxy n), v)])+++{- | analogous flip '//'. Similar to '.<++.', except it is restricted+to cases where the left argument holds a subset of elements.++-}+class HUpdateMany lv rx where+    hUpdateMany :: Record lv -> rx -> rx++instance (RecordValues lv,+          HList2List (RecordValuesR lv) v,+          HFindMany (LabelsOf lv) (LabelsOf r) ixs,+          IArray UArray v,+          v ~ GetElemTy r,+          HNats2Integrals ixs) =>+  HUpdateMany lv (RecordU r) where+  hUpdateMany lv (RecordU r) = RecordU (r // (zip ixs (hList2List (recordValues lv))))+     where ixs = hNats2Integrals (Proxy :: Proxy ixs)++-- | implementation in terms of '.<++.'+instance (HLeftUnion lv x lvx,+          HRLabelSet x,+          HLabelSet (LabelsOf x),+          HRearrange (LabelsOf x) lvx x)+  => HUpdateMany lv (Record x) where+    hUpdateMany lv x = hRearrange' (lv .<++. x)++-- | behaves like @map 'HFind'@+class HFindMany (ls :: [k]) (r :: [k]) (ns :: [HNat]) | ls r  -> ns+instance (HFind l r n,+          HFindMany ls r ns) => HFindMany (l ': ls) r (n ': ns)++instance HFindMany '[] r '[]++instance (ApplyAB f (GetElemTy x) (GetElemTy y),+          IArray UArray (GetElemTy y),+          IArray UArray (GetElemTy x)) => HMapAux RecordU f x y where+    hMapAux f (RecordU x) = RecordU (amap (applyAB f) x)++-- | 'hMap' specialized to 'RecordU'+hMapRU :: HMapCxt RecordU f x y => f -> RecordU x -> RecordU y+hMapRU f = hMap f+++-- | @Iso (Record x) (Record y) (RecordU x) (RecordU y)@+unboxed :: forall x y f p.+  (Profunctor p,+   Functor f,+   RecordToRecordU x,+   RecordUToRecord y)+  => RecordU x `p` f (RecordU y)+  -> Record x `p` f (Record y)+unboxed r = iso recordToRecordU recordUToRecord r++-- | @Iso' (Record x) (RecordU x)@+unboxed' x = isSimple unboxed x+++class RecordToRecordU x where+    recordToRecordU :: Record x -> RecordU x++instance (+    RecordValues x,+    HList2List (RecordValuesR x) (GetElemTy x),+    HNat2Integral n,+    HLengthEq x n,+    IArray UArray (GetElemTy x)+   ) => RecordToRecordU x where+  recordToRecordU (rx@(Record x)) = RecordU $ listArray+          (0, hNat2Integral (hLength x) - 1)+          (hList2List (recordValues rx))+ +class RecordUToRecord x where+    recordUToRecord :: RecordU x -> Record x++instance (+    HMapCxt HList TaggedFn (RecordValuesR x) x,+    IArray UArray (GetElemTy x),+    HList2List (RecordValuesR x) (GetElemTy x) +  ) => RecordUToRecord x where+  recordUToRecord (RecordU b) = case list2HList $ elems b of+          Nothing -> error "Data.HList.RecordU.recordUToRecord impossibly too few elements"+          Just y0 -> Record $ hMap TaggedFn (y0 :: HList (RecordValuesR x))++++-- * definitions for doctest examples+type Bad =+         [Tagged "x" Double,+          Tagged "i" Int,+          Tagged "y" Double,+          Tagged "j" Int]++{- | HasField instances++[@RecordUS@]++>>> let r = recordToRecordUS (sortForRecordUS bad)+>>> let s = recordToRecordUS bad++>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let i = Label :: Label "i"+>>> let j = Label :: Label "j"++>>> (r .!. x, r .!. i, r .!. y, r .!. j)+(1.0,2,3.0,4)++>>> (s .!. x, s .!. i, s .!. y, s .!. j)+(1.0,2,3.0,4)+++[@RecordU@]++>>> let t = recordToRecordU bad1+>>> (t .!. x, t .!. y)+(1.0,2.0)++>>> hUpdateAtLabel x 3 t .!. x+3.0++-}+bad :: Record Bad+bad = Tagged 1 .*. Tagged 2 .*. Tagged 3 .*. Tagged 4 .*. emptyRecord++bad1 :: Record [Tagged "x" Double, Tagged "y" Double]+bad1 = Tagged 1 .*. Tagged 2 .*. emptyRecord++-- * Implementation Details++data UnboxF = UnboxF+instance (hx ~ HList x, ux ~ RecordU x,+          RecordToRecordU x) =>+  ApplyAB UnboxF hx ux where+  applyAB _ = recordToRecordU . Record++data BoxF = BoxF++instance (ux ~ RecordU x,+         hx ~ HList x,+         RecordUToRecord x) =>+  ApplyAB BoxF ux hx where+  applyAB _ ux = case recordUToRecord ux of Record hx -> hx+++-- | make a @Lens' (RecordU s) a@+instance (s ~ t, a ~ b,+          IArray UArray a, a ~ GetElemTy s,+          HLensCxt x RecordU s t a b)+        => Labelable x RecordU s t a b where+            type LabelableTy RecordU = LabelableLens+            hLens' x = hLens x++{- TODO+instance Labelable x RecordUS to p f s t a b where+instance (r ~ r', HasField l (Record r) v)+      => HUpdateAtLabel RecordUS l v r r' where+  hUpdateAtLabel = error "recordus hupdateatlabel"++Benchmarks+-}
Data/HList/TIC.hs view
@@ -1,60 +1,203 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP #-}  {- |    The HList library     (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke -   Type-indexed co-products.+   Type-indexed co-products. The public interface is exposed+   in <Data-HList-CommonMain.html#t:TIC CommonMain#TIC>     (There are other ways: see ConsUnion.hs, for example) -}  module Data.HList.TIC where -import Data.Dynamic+import Data.HList.TIP+import Data.HList.FakePrelude+import Data.HList.HListPrelude +import Data.HList.Record+import Data.HList.Variant import Data.HList.HList-import Data.HList.TIP +import Data.HList.HArray +import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif+import Text.ParserCombinators.ReadP+import LensDefs+ -- ----------------------------------------------------------------------------- | A datatype for type-indexed co-products+-- | A datatype for type-indexed co-products. A 'TIC' is just a 'Variant',+-- where the elements of the type-level list @\"l\"@ are in the form+-- @Tagged x x@. -newtype TIC (l :: [*]) = TIC Dynamic+newtype TIC (l :: [*]) = TIC (Variant l) +deriving instance Eq (Variant l) => Eq (TIC l)+deriving instance Ord (Variant l) => Ord (TIC l)+deriving instance Ix (Variant l) => Ix (TIC l)+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+    hMapAux f (TIC a) = TIC (hMapAux f a)++-- | @Iso (TIC s) (TIC t) (Variant s) (Variant t)@+--+-- 'typeIndexed' may be more appropriate+ticVariant x = isoNewtype (\(TIC a) -> a) TIC x++-- | @Iso' (TIC s) (Variant s)@+ticVariant' x = isSimple ticVariant x++ -- --------------------------------------------------------------------------++{- | Conversion between type indexed collections ('TIC' and 'TIP')+and the corresponding collection that has other label types ('Variant'+and 'Record' respectively)++See 'typeIndexed''++-}+class TypeIndexed r tr | r -> tr, tr -> r where+    -- | @Iso (r s) (r t) (tr a) (tr b)@+    typeIndexed :: forall p f s t a b.+       (TypeIndexedCxt s t a b, Profunctor p, Functor f) =>+      p (tr (TagR a)) (f (tr (TagR b))) -> p (r s) (f (r t))++type TypeIndexedCxt s t a b =+ (HMapCxt HList TaggedFn b t,+  RecordValues s, RecordValues t,+  a ~ RecordValuesR s,+  b ~ RecordValuesR t,+  SameLabels s t,+  SameLength s t,+  SameLength b a,+  {- to use castVariant instead of unsafeCastVariant+  RecordValuesR (TagR a) ~ a,+  RecordValuesR (TagR b) ~ b,+  SameLength (TagR a) s,+  SameLength (TagR b) t,+  -}+  Coercible (TagR b) t,+  Coercible (TagR a) s,+  HAllTaggedLV s,+  HRLabelSet t,+  TagUntag a,+  TagUntag b)++instance TypeIndexed Record TIP where+    typeIndexed = sameLength . unlabeled . fromTipHList+      where fromTipHList = iso (TIP . hTagSelf) (\(TIP a) -> hUntagSelf a)++instance TypeIndexed Variant TIC where+    typeIndexed = isoNewtype unsafeCastVariant unsafeCastVariant+                . isoNewtype TIC (\(TIC a) -> a)++{- |++@'Iso'' ('Variant' s) ('TIC' a)@++@'Iso'' ('Record' s) ('TIP' a)@++where @s@ has a type like @'[Tagged \"x\" Int]@, and+@a@ has a type like @'[Tagged Int Int]@.+-}+typeIndexed' x = isSimple typeIndexed x++-- -------------------------------------------------------------------------- -- | Public constructor (or, open union's injection function) -mkTIC :: ( HTypeIndexed l-         , HMember i l True-         , Typeable i+mkTIC' :: forall i l proxy.+         ( HTypeIndexed l+         , MkVariant i i l          )-      => i -> TIC l+      => i+      -> proxy l -- ^ the ordering of types in the @l :: [*]@ matters.+                 -- This argument is intended to fix the ordering+                 -- it can be a Record, Variant, TIP, Proxy+      -> TIC l -mkTIC i = TIC (toDyn i)+mkTIC' i p = TIC (mkVariant (Label :: Label i) i p) +-- | make a TIC that contains one element+mkTIC1 :: forall i. MkVariant i i '[Tagged i i] => i -> TIC '[Tagged i i]+mkTIC1 i = TIC (mkVariant1 (Label :: Label i) i) +-- | make a TIC for use in contexts where the result type is fixed+mkTIC i = mkTIC' i Proxy++ -- -------------------------------------------------------------------------- -- | Public destructor (or, open union's projection function)+instance HasField o (Variant l) (Maybe o) =>+      HasField o (TIC l) (Maybe o) where+    hLookupByLabel l (TIC i) = hLookupByLabel l i -unTIC :: ( HTypeIndexed l-         , HMember o l True-         , Typeable o-         )-      => TIC l -> Maybe o -unTIC (TIC i) = fromDynamic i+instance (HasField o (TIC l) mo, mo ~ Maybe o) => HOccurs mo (TIC l) where+    hOccurs = hLookupByLabel (Label :: Label o)  +-- | similar to 'HPrism'+class TICPrism s t a b | s a b -> t, t a b -> s where+  ticPrism :: (SameLength s t, Choice p, Applicative f)+      => (a `p` f b) -> (TIC s `p` f (TIC t))++instance (+    MkVariant b b t,+    HasField a (Variant s) (Maybe a),+    SameLength s t,++    HFindLabel b t n,+    HFindLabel a s n,++    HUpdateAtHNatR n (Tagged b b) s ~ t,+    HUpdateAtHNatR n (Tagged a a) t ~ s++    ) => TICPrism s t a b where+  ticPrism = ticVariant . prism (\b -> mkVariant (Label :: Label b) b Proxy)+      (\s -> case hLookupByLabel (Label :: Label a) s of+          Just a -> Right a+          Nothing -> Left (unsafeCastVariant s :: Variant t))++-- | @Prism' (TIC s) a@+ticPrism' :: forall s t a b. (HPrism a s t a b, a~b, s~t)+  => (forall f p. (Applicative f, Choice p) => (a `p` f b) -> (TIC s `p` f (TIC t)))+ticPrism' = ticVariant . hPrism (Label :: Label a)++ -- ----------------------------------------------------------------------------- | TICs are opaque+-- | TICs are not opaque -instance Show (TIC l)+instance ShowVariant l => Show (TIC l)  where-  show _ = "<Cannot show TIC content!>"+  showsPrec _ (TIC v) = ("TIC{"++) . showVariant v . ('}':) ++instance (ReadVariant l, HAllTaggedEq l, HRLabelSet l) => Read (TIC l)+ where+   readsPrec _ = readP_to_S $ do+     _ <- string "TIC{"+     r <- readVariant+     _ <- string "}"+     return (TIC r)+++{- |+> Nothing .*. x = x+> Just a .*. y = mkTIC a+-}+instance (me ~ Maybe e, HOccursNot (Tagged e e) l)+       => HExtend me (TIC l) where+    type HExtendR me (TIC l) = TIC (Tagged (UnMaybe me) (UnMaybe me) ': l)+    Just e .*. _ = TIC (unsafeMkVariant 0 e)+    Nothing .*. TIC x = TIC (extendVariant x)
Data/HList/TIP.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  {- |    The HList library@@ -5,26 +6,54 @@    (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke     Type-indexed products.+   The public interface is described in+   <Data-HList-CommonMain.html#t:TIP CommonMain#TIP> -} -module Data.HList.TIP where+module Data.HList.TIP+  (module Data.HList.TIPtuple,+   module Data.HList.TIP) where   import Data.HList.HListPrelude+import Data.HList.FakePrelude import Data.HList.HList-import Data.HList.HArray ()-import Data.HList.HTypeIndexed+import Data.HList.Record+import Data.HList.HTypeIndexed ()+import Data.HList.TIPtuple+import Data.List (intercalate)+import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif -import Data.HList.TypeEqO () -- for doctest+#if __GLASGOW_HASKELL__ > 710+import Data.Coerce+#endif +import LensDefs+ -- -------------------------------------------------------------------------- -- * The newtype for type-indexed products +-- | TIPs are like 'Record', except element \"i\" of the list \"l\"+-- has type @Tagged e_i e_i@ newtype TIP (l :: [*]) = TIP{unTIP:: HList l} -instance Show (HList l) => Show (TIP l) where-  show (TIP l) = "TIP" ++ show 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)+deriving instance (Ix (HList r)) => Ix (TIP r)+deriving instance (Bounded (HList r)) => Bounded (TIP r) ++instance HMapOut (HShow `HComp` HUntag) l String => Show (TIP l) where+  showsPrec _ (TIP l) = ("TIPH[" ++)+                              . (intercalate "," (hMapOut (HShow `HComp` HUntag) l) ++)+                              . (']' :)++ mkTIP :: HTypeIndexed l => HList l -> TIP l mkTIP = TIP @@ -34,19 +63,29 @@ -- -------------------------------------------------------------------------- -- * Type-indexed type sequences -class HTypeIndexed (l :: [*])-instance HTypeIndexed '[]-instance (HOccursNot e l,HTypeIndexed l) => HTypeIndexed (e ': l)+-- | this constraint ensures that a TIP created by 'mkTIP' has no+-- duplicates+class (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed (l :: [*]) +instance (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed l++class HAllTaggedEq (l :: [*])+instance HAllTaggedEq '[]+instance (HAllTaggedEq l, tee ~ Tagged e e') => HAllTaggedEq (tee ': l)+ -- -------------------------------------------------------------------------- -- Implementing the HListPrelude interface -instance (HOccursNot e l, HTypeIndexed l) => HExtend e (TIP l) +instance (HRLabelSet (Tagged e e ': l), HTypeIndexed l) => HExtend e (TIP l)  where-  type HExtendR e (TIP l) = TIP (e ': l)-  e .*. TIP l = mkTIP (HCons e l)+  type HExtendR e (TIP l) = TIP (Tagged e e ': l)+  e .*. TIP l = mkTIP (HCons (Tagged e) l)  ++instance (e ~ e', HasField e (Record l) e') => HasField e (TIP l) e' where+    hLookupByLabel lab (TIP l) = hLookupByLabel lab (Record l)+ -- | One occurrence and nothing is left -- -- This variation provides an extra feature for singleton lists.@@ -54,43 +93,102 @@ -- Hence the explicit provision of a result type can be omitted. -- -instance e' ~ e => HOccurs e' (TIP '[e]) where-  hOccurs (TIP (HCons e' _)) = e'+instance (tee ~ Tagged e e) => HOccurs e (TIP '[tee]) where+  hOccurs (TIP (HCons (Tagged e) _)) = e -instance HOccurs e (HList (x ': y ': l))+instance HasField e (Record (x ': y ': l)) e       => HOccurs e (TIP (x ': y ': l)) where-  hOccurs (TIP l) = hOccurs l---instance HOccursNot e l => HOccursNot e (TIP l)+  hOccurs (TIP l) = Record l .!. (Label :: Label e)  -instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendList l l'))+instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendListR l l'))            => HAppend (TIP l) (TIP l')  where   hAppend (TIP l) (TIP l') = mkTIP (hAppend l l') -type instance HAppendR (TIP l) (TIP l') = TIP (HAppendList l l')+type instance HAppendR (TIP l) (TIP l') = TIP (HAppendListR l l') --- instance HOccurrence e l l' => HOccurrence e (TIP l) l'++-- instance HOccurrence HList e l l' => HOccurrence TIP e l l' --  where---   hOccurrence e = hOccurrence e . unTIP+--   hOccurrence e = TIP . hOccurrence e . unTIP  -- -------------------------------------------------------------------------- -- * Shielding type-indexed operations -- $note The absence of signatures is deliberate! They all must be inferred. -onTIP f (TIP l) = mkTIP (f l)+onRecord f (TIP l) = let Record l' = f (Record l) in mkTIP l' -tipyDelete  p t  = onTIP (hDeleteAt p) t-tipyUpdate  e t  = onTIP (hUpdateAt e) t-tipyProject ps t = onTIP (hProjectBy ps) t+instance (HDeleteAtLabel Record e v v',+          HTypeIndexed v')+      => HDeleteAtLabel TIP e v v' where+  hDeleteAtLabel e v = onRecord (hDeleteAtLabel e) v  --- | Split produces two TIPs-tipySplit ps (TIP l) = (mkTIP l',mkTIP l'')+tipyUpdate  e t  = hTPupdateAtLabel (fromValue e) e t+  where fromValue :: e -> Label e+        fromValue _ = Label++instance (HUpdateAtLabel Record e' e r r',+          HTypeIndexed r',+         e ~ e') => HUpdateAtLabel TIP e' e r r' where+  hUpdateAtLabel l e r = onRecord (hUpdateAtLabel l e) r+++-- | Use 'Labels' to specify the first argument+tipyProject ps t = onRecord (hProjectByLabels ps) t++-- | provides a @Lens' (TIP s) a@. 'hLens'' @:: Label a -> Lens' (TIP s) a@+-- is another option.+#if __GLASGOW_HASKELL__ < 707+tipyLens' x = isSimple tipyLens x -- rejected by GHC-7.10RC1+#else+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+    getA _ = Label++    asTIP :: TIP a -> TIP a+    asTIP = id+#endif++{- | provides a @Lens (TIP s) (TIP t) a b@++When using @set@ (also known as @.~@), 'tipyLens'' can address the+ambiguity as to which field \"a\" should actually be updated.++-}+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+    getN :: HFind (Label a) (LabelsOf s) n => HList s -> (a -> f b) -> Proxy n+    getN _ _ = Proxy++    -- 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'')  where-  (l',l'') = hSplitBy ps l+  (l',l'') = h2projectByLabels ps l   -- --------------------------------------------------------------------------@@ -103,14 +201,300 @@   -- --------------------------------------------------------------------------+-- * conversion to and from 'HList' +{- | 'TagR' can also be used to avoid redundancy when defining types for TIC and TIP.++>  type XShort = TagR [A,B,C,D]++>  type XLong = [Tagged A A, Tagged B B, Tagged C C, Tagged D D]+++an equivalent FD version, which is slightly better with respect to+simplifying types containing type variables (in ghc-7.8 and 7.6):+<http://stackoverflow.com/questions/24110410/>++With ghc-7.10 (<http://ghc.haskell.org/trac/ghc/ticket/10009>) the FD version is superior+to the TF version:++@+class (UntagR (TagR a) ~ a) => TagUntag a where+    type TagR a :: [*]+    hTagSelf :: HList a -> HList (TagR a)+    hUntagSelf :: HList (TagR a) -> HList a++instance TagUntag '[] where+    type TagR '[] = '[]+    hTagSelf _ = HNil+    hUntagSelf _ = HNil++instance TagUntag xs => TagUntag (x ': xs) where+    type TagR (x ': xs) = Tagged x x ': TagR xs+    hTagSelf (HCons x xs) = Tagged x `HCons` hTagSelf xs+    hUntagSelf (HCons (Tagged x) xs) = x `HCons` hUntagSelf xs++type family UntagR (xs :: [*]) :: [*]+type instance UntagR '[] = '[]+type instance UntagR (x ': xs) = Untag1 x ': UntagR xs+@++Length information should flow backwards++>>> let len2 x = x `asTypeOf` (undefined :: HList '[a,b])+>>> let f = len2 $ hTagSelf (hReplicate Proxy ())+>>> :t f+f :: HList '[Tagged () (), Tagged () ()]++-}+class SameLength a ta => TagUntagFD a ta | a -> ta, ta -> a where+    hTagSelf :: HList a -> HList ta+    hUntagSelf :: HList ta -> HList a++instance TagUntagFD '[] '[] where+    hTagSelf _ = HNil+    hUntagSelf _ = HNil++instance (TagUntagFD xs ys, txx ~ Tagged x x)+      => TagUntagFD (x ': xs) (txx ': ys) where+    hTagSelf (HCons x xs) = Tagged x `HCons` hTagSelf xs+    hUntagSelf (HCons (Tagged x) xs) = x `HCons` hUntagSelf xs++type TagUntag xs = TagUntagFD xs (TagR xs)++-- | 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 = (TagR (UntagR xs) ~ xs, TagUntagFD (UntagR xs) xs)++type family TagR (a :: [*]) :: [*]+type family UntagR (ta :: [*]) :: [*]++type instance TagR '[] = '[]+type instance UntagR '[] = '[]++type instance TagR (x ': xs) = Tagged x x ': TagR xs+type instance UntagR (Tagged y y ': ys) = y ': UntagR ys++type family Untag1 (x :: *) :: *+type instance Untag1 (Tagged k x) = x+++-- | @Iso (TIP (TagR a)) (TIP (TagR b)) (HList a) (HList b)@+tipHList x = iso (\(TIP a) -> hUntagSelf a) (TIP . hTagSelf) x++-- | @Iso' (TIP (TagR s)) (HList a)@+tipHList' x = isSimple tipHList x+++-- * conversion to and from 'Record'++-- | @Iso (TIP s) (TIP t) (Record s) (Record t)@+--+-- 'typeIndexed' may be more appropriate+tipRecord x = isoNewtype (\(TIP a) -> Record a) (\(Record b) -> TIP b) x++-- | @Iso' (TIP (TagR s)) (Record a)@+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],+          HTypeIndexed x, HTypeIndexed y,+          HUnzip TIP x y xy+          -- HTypeIndexed xy is always satisfied given the above+          -- constraints (with a handwaving proof), so don't require+          -- callers of hZip/hUnzip to supply such proof+    ) => HZip TIP x y xy where+  hZip = hZipTIP+++instance (HZipList (UntagR x) (UntagR y) (UntagR xy),+          UntagTag x, UntagTag y, UntagTag xy,+          HTypeIndexed x, HTypeIndexed y,+          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)))++-- | specialization of 'hUnzip'+hUnzipTIP (TIP xy) = case hUnzipList (hUntagSelf xy) of+  (x,y) -> (mkTIP (hTagSelf x), mkTIP (hTagSelf y))++++-- --------------------------------------------------------------------------+-- * TIP Transform++{- |++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.++Examples can be found in @examples/TIPTransform.hs@ and @examples/TIPTransformM.hs@+-}++class TransTIP op db where+    ttip :: op -> TIP db -> TIP db++instance (HMember (Tagged op op) db b,+          Arity op n,+          TransTIP1 b n op db)+    => TransTIP op db where+    ttip = ttip1 (Proxy ::Proxy b) (Proxy :: Proxy n)++class TransTIP1 (b :: Bool) (n :: HNat) op db where+    ttip1 :: Proxy b -> Proxy n -> op -> TIP db -> TIP db++-- If op is found in a TIP, update the TIP with op+instance HTPupdateAtLabel TIP op op db+    => TransTIP1 True n op db where+    ttip1 _ _ = tipyUpdate++-- If op is not found in a TIP, it must be a function. Try to look up+-- its argument in a TIP and recur.+instance (HMember (Tagged arg arg) db b,+          TransTIP2 b arg op db)+    => TransTIP1 False (HSucc n) (arg -> op) db where+    ttip1 _ _ = ttip2 (Proxy :: Proxy b)++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++instance (HOccurs arg (TIP db),+         TransTIP op db)+   => TransTIP2 True arg op db where+    ttip2 _ f db = ttip (f (hOccurs db)) db++instance Fail (FieldNotFound arg (TIP db))+    => TransTIP2 False arg op db where+    ttip2 = error "TransTIP2 Fail failed"++-- ** Monadic version++{- |++In March 2010, Andrew Frank extended the problem for monadic operations.+This is the monadic version of @TIPTransform.hs@ in the present directory.++This is the TF implementation. When specifying the operation to perform over+a TIP, we can leave it polymorphic over the monad. The type checker+will instantiate the monad based on the context.++-}+class Monad m => TransTIPM m op db where+    ttipM :: op -> TIP db -> m (TIP db)++-- Check to see if the operation is a computation whose result+-- is in the TIP. The type variable m' of the kind *->* below+-- can be instantiated either to a monad type constructor, or (arg->).+instance (Monad m, HMember (Tagged op op) db b,+           Arity (m' op) n,+           TransTIPM1 b n m (m' op) db)+    => TransTIPM m (m' op) db where+    ttipM = ttipM1 (Proxy :: Proxy b) (Proxy :: Proxy n)++class Monad m => TransTIPM1 (b :: Bool) (n :: HNat) m op db where+    ttipM1 :: Proxy b -> Proxy n -> op -> TIP db -> m (TIP db)++-- If op is found in a TIP, update the TIP with op.+-- The type variable m' must be equal to the type of the monad+-- in which the final result is reported.+instance (Monad m, m ~ m', HTPupdateAtLabel TIP op op db)+    => TransTIPM1 True n m (m' op) db where+    ttipM1 _ _ op db = do+         op' <- op+         return $ tipyUpdate op' db++instance (Fail (FieldNotFound op (TIP db)), Monad m)+    => TransTIPM1 False HZero m op db where+    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.+instance (Monad m,+          HMember (Tagged arg arg) db b,+          TransTIPM2 b m arg op db)+    => TransTIPM1 False (HSucc n) m (arg-> op) db where+    ttipM1 _ _ = ttipM2 (Proxy :: Proxy b)+++class TransTIPM2 (b :: Bool) m arg op db where+    ttipM2 :: Proxy b -> (arg -> op) -> TIP db -> m (TIP db)++instance (HOccurs arg (TIP db), TransTIPM m op db)+      => TransTIPM2 True m arg op db where+    ttipM2 _ f db = ttipM (f (hOccurs db)) db+++instance Fail (FieldNotFound op (TIP db))+    => TransTIPM2 False m arg op db where+    ttipM2 _ _ = error "TransTIPM1 Fail failed"++-- --------------------------------------------------------------------------++-- tests for tipyTuple. These only work if tipyTuple is compiled+-- in a module that has NoMonoLocalBinds enabled+_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Char, Bool)+_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Bool, Char)+++-- --------------------------------------------------------------------------+ -- * Sample code  {- $setup  [@Assume@] +>>> import Data.HList.TypeEqO >>> import Data.HList.FakePrelude+>>> import Data.HList.HOccurs  >>> :{ newtype Key    = Key Integer deriving (Show,Eq,Ord)@@ -118,13 +502,12 @@ data Breed     = Cow | Sheep deriving (Show,Eq) newtype Price  = Price Float deriving (Show,Eq,Ord) data Disease   = BSE | FM deriving (Show,Eq)-type Animal =  '[Key,Name,Breed,Price]+type Animal =  TagR '[Key,Name,Breed,Price] :}  >>> :{-let myAnimal :: HList Animal-    myAnimal = hBuild (Key 42) (Name "Angus") Cow (Price 75.5)-    myTipyCow = TIP myAnimal+let myTipyCow :: TIP Animal -- optional+    myTipyCow = Key 42 .*.  Name "Angus" .*.  Cow .*.  Price 75.5 .*. emptyTIP     animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key     animalKey = hOccurs :}@@ -135,22 +518,32 @@ [@Session log@]  >>> :t myTipyCow-myTipyCow :: TIP Animal+myTipyCow+  :: TIP+       '[Tagged Key Key, Tagged Name Name, Tagged Breed Breed,+         Tagged Price Price]  >>> hOccurs myTipyCow :: Breed Cow  >>> BSE .*. myTipyCow-TIPH[BSE, Key 42, Name "Angus", Cow, Price 75.5]+TIPH[BSE,Key 42,Name "Angus",Cow,Price 75.5]   ->>> Sheep .*. tipyDelete (Proxy::Proxy Breed) myTipyCow-TIPH[Sheep, Key 42, Name "Angus", Price 75.5]+>>> Sheep .*. hDeleteAtLabel (Label::Label Breed) myTipyCow+TIPH[Sheep,Key 42,Name "Angus",Price 75.5]  >>> tipyUpdate Sheep myTipyCow-TIPH[Key 42, Name "Angus", Sheep, Price 75.5]+TIPH[Key 42,Name "Angus",Sheep,Price 75.5] ++>>> tipyProject2 (Proxy :: Labels '[Name,Price]) myTipyCow+(TIPH[Name "Angus",Price 75.5],TIPH[Key 42,Cow])++>>> tipyProject (Proxy :: Labels '[Name,Price]) myTipyCow+TIPH[Name "Angus",Price 75.5]+ -}  @@ -158,9 +551,10 @@  Don't bother repeating the type error: ->>> let doctestEq x y = x == y || "No instance for" `Data.List.isInfixOf` x  >>> Sheep .*. myTipyCow--- type error --+...+...No instance for (Fail (DuplicatedLabel (Label Breed)))+...  -}
+ Data/HList/TIPtuple.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE NoTypeFamilies #-}+{- | Description: TIP functions needing different LANGUAGE extensions++While NoMonoLocalBinds could be enabled in TIP.hs, the ghc manual warns+"type inference becomes less predicatable if you do so. (Read the papers!)".+These definitions don't need type families, putting these definitions in+a separate module avoids that mess.++XXX these should be implemented in terms of 'HTuple' and 'tipyProject',+which means adding+-}+module Data.HList.TIPtuple where++import Data.HList.HOccurs++{- | project a TIP (or HList) into a tuple++@tipyTuple' x = ('hOccurs' x, hOccurs x)@++behaves similarly, except @tipyTuple@ excludes+the possibility of looking up the same element+twice, which allows inferring a concrete type+in more situations. For example++> (\x y z -> tipyTuple (x .*. y .*. emptyTIP) `asTypeOf` (x, z)) () 'x'++has type @Char -> ((), Char)@. tipyTuple' would+need a type annotation to decide whether the type+should be @Char -> ((), Char)@ or @() -> ((), ())@++-}+tipyTuple l = t (,) `asTypeOf` t (flip (,))+  where+  t f = case hOccursRest l of+     (x, ly) -> case hOccursRest ly of+         (y, _) -> f x y++tipyTuple3 l = t (,,)+          `asTypeOf` t (\a b c -> (b,c,a))+          `asTypeOf` t (\a b c -> (c,a,b))+  where+  t f = case hOccursRest l of+    (x, lyz) -> case hOccursRest lyz of+       (y, lz) -> case hOccursRest lz of+          (z, _) -> f x y z++tipyTuple4 l = t (,,,)+          `asTypeOf` t (\a b c d -> (b,c,d,a))+          `asTypeOf` t (\a b c d -> (c,d,a,b))+          `asTypeOf` t (\a b c d -> (d,a,b,c))+  where+  t f = case hOccursRest l of+    (a, lbcd) -> case hOccursRest lbcd of+       (b, lcd) -> case hOccursRest lcd of+          (c, ld) -> case hOccursRest ld of+             (d, _) -> f a b c d++tipyTuple5 l = t (,,,,)+          `asTypeOf` t (\a b c d e -> (b,c,d,e,a))+          `asTypeOf` t (\a b c d e -> (c,d,e,a,b))+          `asTypeOf` t (\a b c d e -> (d,e,a,b,c))+          `asTypeOf` t (\a b c d e -> (e,a,b,c,d))+  where+  t f = case hOccursRest l of+    (a, lbcde) -> case hOccursRest lbcde of+       (b, lcde) -> case hOccursRest lcde of+          (c, lde) -> case hOccursRest lde of+            (d, le) -> case hOccursRest le of+               (e, _) -> f a b c d e
Data/HList/TypeEqO.hs view
@@ -1,13 +1,18 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709) {-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif  {- |    The HList library     (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke -   Generic type equality predicate: +   Generic type equality predicate:    The implementation based on overlapping instances    The only place where overlapping instances are really used+   besides Label5  -} @@ -15,15 +20,36 @@  import Data.HList.FakePrelude -instance HEq x x True-instance False ~ b => HEq x y b+#if !NEW_TYPE_EQ+instance {-# OVERLAPPING #-} HEq x x True+instance {-# OVERLAPPABLE  #-} False ~ b => HEq x y b -- instance TypeEq x y HFalse -- would violate functional dependency+#endif  -class TupleType t (b :: Bool) | t -> b-instance TupleType () True-instance TupleType (x,y) True-instance TupleType (x,y,z) True++class TupleType (t :: *) (b :: Bool) | t -> b+instance {-# OVERLAPPING #-} TupleType () True+instance {-# OVERLAPPING #-} TupleType (x,y) True+instance {-# OVERLAPPING #-} TupleType (x,y,z) True -- Continue for a while-instance False ~ b => TupleType x b+instance {-# OVERLAPPABLE #-} False ~ b => TupleType x b -- instance TupleType x HFalse -- would violate functional dependency++-- overlaps an instance Show (Proxy t) for convenience+instance {-# OVERLAPPING #-} Show (Proxy True)  where show _ = "HTrue"+instance {-# OVERLAPPING #-} Show (Proxy False) where show _ = "HFalse"++instance {-# OVERLAPPING #-} HNat2Integral n => Show (Proxy (n :: HNat)) where+    show n = "H" ++ show (hNat2Integral n :: Integer)+++instance {-# OVERLAPPABLE #-} hZero ~ HZero => ArityFwd f hZero+instance {-# OVERLAPPING #-} Arity f n => ArityFwd (x -> f) (HSucc n)+++-- | All our keywords must be registered+class IsKeyFN (t :: *) (flag :: Bool) | t-> flag+-- | overlapping/fallback case+instance {-# OVERLAPPABLE #-} (False ~ flag) => IsKeyFN t flag+
Data/HList/Variant.hs view
@@ -1,68 +1,1185 @@-{-# 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!>"--+{-# LANGUAGE CPP #-}++{- |+   Description: Variants, i.e., labelled sums, generalizations of Either++   The HList library++   See <Data-HList-CommonMain.html#t:Variant CommonMain#Variant>+   for the public (safe) interface.++   The implementation here follows "Data.Dynamic", though Typeable is not+   needed.++   See @broken/VariantP.hs@ and @broken/VariantOld.hs@ for different approaches+   to open sums.+-}++module Data.HList.Variant where++import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.HList+import Data.HList.HListPrelude+import Data.HList.HOccurs()+import Data.HList.HArray++import Text.ParserCombinators.ReadP hiding (optional)++import Unsafe.Coerce+import GHC.Exts (Constraint)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup( .. ))+#endif+import Data.Data+import Control.Applicative+import LensDefs+import Control.Monad++-- * Labels for doctests++{- $setup++>>> import Data.HList.RecordPuns+>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let z = Label :: Label "z"+>>> let _left = Label :: Label "left"+>>> let _right = Label :: Label "right"++>>> :set -XQuasiQuotes -XViewPatterns -XDataKinds+++-- * Creating Variants++It is necessary to specify the order in which the fields occur, using+a data type like++>>> let p = Proxy :: Proxy '[Tagged "left" Char, Tagged "right" Int]++Then this argument can be passed into 'mkVariant'++>>> let v = mkVariant _left 'x' p+>>> let w = mkVariant _right 5  p++>>> :t v+v :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w+w :: Variant '[Tagged "left" Char, Tagged "right" Int]+++>>> [v,w]+[V{left='x'},V{right=5}]++-}+++-- ** Alternative: a 'Record' as the Proxy+{- $mkVariant2++The type of mkVariant also allows using a 'Record' as the proxy. For example:++>>> :{+let p2 = [pun| left right |] where+            left = 'a'+            right = (4::Int)+:}++>>> let v2 = mkVariant _left 'x' p2+>>> let w2 = mkVariant _right 5  p2++>>> :t v2+v2 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w2+w2 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> (v2,w2)+(V{left='x'},V{right=5})++-}++-- ** A polymorphic Proxy+{- $mkVariant3++It is also possible to leave the @Char@ and @Int@ as type variables,+and have them inferred.++>>> let p3 = Proxy :: Proxy '[Tagged "left" a, Tagged "right" b]++Using @p3@ takes some care. The following attempt shows the problem:++>>> :{+let v3' = mkVariant _left 'x' p3+    w3' = mkVariant _right (5::Int) p3+:}++>>> :t v3'+v3' :: Variant '[Tagged "left" Char, Tagged "right" b]++>>> :t w3'+w3' :: Variant '[Tagged "left" a, Tagged "right" Int]++Here each use of @p3@ does not constrain the type of the other use.+In some cases those type variables will be inferred from other constraints,+such as when putting the variants into a list++>>> [v3', w3']+[V{left='x'},V{right=5}]++In other cases the other tags will be defaulted to (), at least if `ExtendedDefaultRules` is enabled:++>>> v3'+V{left='x'}++>>> :set -XNoExtendedDefaultRules+>>> v3'+...+...No instance for (Show ...) arising from a use of ‘print’+...+++Another way around this issue is to make sure that the proxy+is bound in a monomorphic pattern. These are patterns that allow+name shadowing.++* @\p -> ...@+* @case e of p -> ...@+* @do p <- e; ...@+* implicit parameters @let ?p = e in ...@+* <http://stackoverflow.com/questions/23899279#23899611 other patterns involved in mutually recursive bindings>++An example of the case:++>>> :{+let (v3,w3) = case p3 of+              p -> (mkVariant _left 'x' p,+                    mkVariant _right (5 :: Int) p)+:}+++>>> :t v3+v3 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w3+w3 :: Variant '[Tagged "left" Char, Tagged "right" Int]++-}++-- --------------------------------------------------------------------------+{- |+@Variant vs@ has an implementation similar to 'Dynamic', except the+contained value is one of the elements of the @vs@ list, rather than+being one particular instance of 'Typeable'.++>>> v .!. _right+Nothing++>>> v .!. _left+Just 'x'++In some cases the 'pun' quasiquote works with variants,++>>> let f [pun| left right |] = (left,right)+>>> f v+(Just 'x',Nothing)++>>> f w+(Nothing,Just 5)+++>>> let add1 v = hMapV (Fun succ :: Fun '[Enum] '()) v++>>> f (add1 v)+(Just 'y',Nothing)++>>> f (add1 w)+(Nothing,Just 6)+++-}+data Variant (vs :: [*]) = Variant !Int Any++#if __GLASGOW_HASKELL__ > 707+-- the inferred role is phantom, which is not safe+type role Variant representational+#endif++++-- ** Unsafe operations++-- | This is only safe if the n'th element of vs has type @Tagged t v@+unsafeMkVariant :: Int -- ^ n+                -> v+                -> Variant vs+unsafeMkVariant n a = Variant n (unsafeCoerce a)++{- | Safe when (e ~ e') given that++> Tagged t e ~ HLookupByHNatR n v+> Tagged t' e' ~ HLookupByHNatR n v'++'hUpdateAtLabel' is the safe version++-}+unsafeCastVariant :: Variant v -> Variant v'+unsafeCastVariant (Variant n e) = Variant n e++-- | in ghc>=7.8, 'Data.Coerce.coerce' is probably a better choice+castVariant :: (RecordValuesR v ~ RecordValuesR v',+              SameLength v v') => Variant v -> Variant v'+castVariant = unsafeCastVariant++instance Relabeled Variant where+    relabeled = iso castVariant castVariant++-- | private destructor. This is safe only if the value+-- contained actually has type `e`+unsafeUnVariant :: Variant v -> e+unsafeUnVariant (Variant _ e) = unsafeCoerce e+++{- | This function is unsafe because it can lead to a runtime error+when used together with the 'HExtend' instance (.*.)++>>> print $ (Label :: Label "x") .=. (Nothing :: Maybe ()) .*. unsafeEmptyVariant+V{*** Exception: invalid variant++use 'mkVariant1' instead++-}+unsafeEmptyVariant :: Variant '[]+unsafeEmptyVariant = unsafeMkVariant 0 ()++-- --------------------------------------------------------------------------+-- * Public constructor++class HasField x (Variant vs) (Maybe v) =>+      MkVariant x v vs | x vs -> v where+    mkVariant :: Label x -- ^ the tag+        -> v -- ^ value to be stored+        -> proxy vs -- ^ a helper to fix the ordering and types of the+                    -- potential values that this variant contains.+                    -- Typically this will be a 'Proxy', 'Record' or+                    -- another 'Variant'+        -> Variant vs++mkVariant1 l v = l .=. Just v .*. unsafeEmptyVariant++instance (HFindLabel x vs n,+          HNat2Integral n,+          HasField x (Variant vs) (Maybe v)) =>+    MkVariant x v vs where+  mkVariant _x y _p = unsafeMkVariant (hNat2Integral (Proxy :: Proxy n)) y+  -- done as a one-instance class instead of a function to be able to hide+  -- the 'n' type variable++-- --------------------------------------------------------------------------+-- * Public destructor++{- $note 'hLookupByLabel' (synonym '.!.')++> (.!.)             :: Variant v -> Label x -> Maybe e+> hLookupByLabel    :: Label x -> Variant v -> Maybe e++'hPrism' and 'hLens'' combine this with 'mkVariant'+-}+instance (HasField x (Record vs) a,+          HFindLabel x vs n,+          HNat2Integral n)+  => HasField x (Variant vs) (Maybe a) where+  hLookupByLabel _x (Variant n d)+          | hNat2Integral (Proxy :: Proxy n) == n = Just (unsafeCoerce d)+          | otherwise = Nothing++splitVariant1 :: Variant (Tagged s x ': xs) -> Either x (Variant xs)+splitVariant1 (Variant 0 x) = Left (unsafeCoerce x)+splitVariant1 (Variant n x) = Right (Variant (n-1) x)++-- | x ~ Tagged s t+splitVariant1' :: Variant (x ': xs) -> Either x (Variant xs)+splitVariant1' (Variant 0 x) = Left (unsafeCoerce x)+splitVariant1' (Variant n x) = Right (Variant (n-1) x)++extendVariant :: Variant l -> Variant (e ': l)+extendVariant (Variant m e) = Variant (m+1) e++-- --------------------------------------------------------------------------+-- * Prism++{- | Make a @Prism (Variant s) (Variant t) a b@ out of a Label.++See "Data.HList.Labelable".'hLens'' is a more overloaded version.++Few type annotations are necessary because of the restriction+that `s` and `t` have the same labels in the same order, and to+get \"t\" the \"a\" in \"s\" is replaced with \"b\".++-}+class (SameLength s t, SameLabels s t)+        => HPrism x s t a b+          | x s -> a, x t -> b,    -- lookup+            x s b -> t, x t a -> s -- update+  where+    hPrism :: (Choice p, Applicative f)+        => Label x -> p a (f b) -> p (Variant s) (f (Variant t))+++instance (+    MkVariant x b t,++    HasField x (Variant s) (Maybe a),++    -- labels in the HList are not changed at all:+    -- number, ordering, actual values are all constant+    SameLength s t,+    SameLabels s t,++    -- only the target of the prism can have it's type changed+    H2ProjectByLabels '[Label x] s si so,+    H2ProjectByLabels '[Label x] t ti to,+    so ~ to,++    -- to convince GHC the fundeps are satisfied+    HUpdateAtLabel Variant x b s t,+    HUpdateAtLabel Variant x a t s+   ) => HPrism x s t a b where+    hPrism x = prism (\b -> mkVariant x b Proxy)+                  (\s -> case hLookupByLabel x s of+                    Just a -> Right a+                    Nothing -> Left (unsafeCastVariant s :: Variant t))++++-- --------------------------------------------------------------------------+-- * Read+-- | Variants are not opaque+instance (ShowVariant vs) => Show (Variant vs) where+    showsPrec _ v = ("V{"++) . showVariant v . ('}':)+++-- | helper class for defining the Show instance+class ShowVariant vs where+    showVariant :: Variant vs -> ShowS++instance (ShowLabel l, Show v, ShowVariant (w ': ws))+      => ShowVariant (Tagged l v ': w ': ws) where+    showVariant vs = case splitVariant1 vs of+        Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest+        Right wws -> showVariant wws+      where l = Label :: Label l++instance (ShowLabel l, Show v, lv ~ Tagged l v) => ShowVariant '[lv] where+    showVariant vs = case splitVariant1 vs of+        Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest+        Right _ -> error "invalid variant"+      where l = Label :: Label l++-- --------------------------------------------------------------------------+-- * Show+-- | A corresponding read instance++instance ReadVariant v => Read (Variant v) where+    readsPrec _ = readP_to_S $ do+      _ <- string "V{"+      r <- readVariant+      _ <- string "}"+      return r++class ReadVariant vs where+    readVariant :: ReadP (Variant vs)++instance ReadVariant '[] where+    readVariant = return unsafeEmptyVariant++instance (ShowLabel l, Read v, ReadVariant vs,+          HOccursNot (Label l) (LabelsOf vs))+    => ReadVariant (Tagged l v ': vs) where+    readVariant = do+      mlv <- optional lv+      case mlv of+        Nothing -> do+          rest <- readVariant+          return (l .=. mlv .*. rest)+        Just e -> do+          return (mkVariant l e p)++      where+        lv = do+            _ <- string (showLabel l)+            _ <- string "="+            readS_to_P reads++        l = Label :: Label l++        p = Proxy :: Proxy (Tagged l v ': vs)+++-- * Data+instance (Typeable (Variant v), GfoldlVariant v v,+          GunfoldVariant v v,+          VariantConstrs v)+        => Data (Variant v) where+    gfoldl = gfoldlVariant+    gunfold k z c = gunfoldVariant (\con -> k (z con)) (Proxy :: Proxy v) (constrIndex c - 1)+    toConstr v@(Variant n _) = case drop n (variantConstrs (dataTypeOf v) v) of+        c : _ -> c+        _ -> error "Data.HList.Variant.toConstr impossible"+    dataTypeOf x = let self = mkDataType (show (typeOf x)) (variantConstrs self x)+          in self++class VariantConstrs (xs :: [*]) where+  variantConstrs :: DataType -> proxy xs -> [Constr]++instance VariantConstrs '[] where+  variantConstrs _ _ = []++instance (ShowLabel l, VariantConstrs xs) => VariantConstrs (Tagged l e ': xs) where+  variantConstrs dt _ = mkConstr dt (showLabel (Label :: Label l)) [] Prefix :+        variantConstrs dt (Proxy :: Proxy xs)+++++{- | [@implementation of gunfold for Variant@]++In ghci++> :set -ddump-deriv -XDeriveDataTypeable+> data X a b c = A a | B b | C c deriving (Data,Typeable)++shows that gunfold is defined something like++> gunfold k z c = case constrIndex c of+>       1 -> k (z Ghci1.A)+>       2 -> k (z Ghci1.B)+>       _ -> k (z Ghci1.C)++If we instead had++> type X a b c = Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]++Then we could write:++> gunfold1 :: (forall b r. Data b => (b -> r) -> c r)+>          -> Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]+> gunfold1 f c = case constrIndex c of+>       1 -> f mkA+>       2 -> f mkB+>       _ -> f mkC+>   where mkA a = mkVariant (Label :: Label "A") (a :: a) v+>         mkB b = mkVariant (Label :: Label "B") (b :: b) v+>         mkC c = mkVariant (Label :: Label "C") (c :: c) v+>         v = Proxy :: Proxy [Tagged "A" a, Tagged "B" b, Tagged "C" c]++where @f = k.z@+++-}+class GunfoldVariant (es :: [*]) v where+    gunfoldVariant ::+        (forall b. Data b => (b -> Variant v) -> c (Variant v))+          -- ^ @f = k . z@+        -> Proxy es+        -> Int+        -> c (Variant v)++instance (MkVariant l e v, Data e) => GunfoldVariant '[Tagged l e] v where+    gunfoldVariant f _ _ = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy)++instance (MkVariant l e v, Data e,+        GunfoldVariant (b ': bs) v) => GunfoldVariant (Tagged l e ': b ': bs)  v where+    gunfoldVariant f _ 0 = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy)+    gunfoldVariant f _ n = gunfoldVariant f (Proxy :: Proxy (b ': bs)) (n-1)++++class GfoldlVariant xs xs' where+  -- | the same as 'gfoldl', except the variant that is returned can have more+  -- possible values (needed to actually implement gfoldl).+  gfoldlVariant ::+     (forall d b. Data d => c (d -> b) -> d -> c b)+     -> (forall g. g -> c g) -> Variant xs -> c (Variant xs')++instance (a ~ Tagged l v, MkVariant l v r, Data v,+          GfoldlVariant (b ': c) r)+      => GfoldlVariant (a ': b ': c) r where+  gfoldlVariant k z xxs = case splitVariant1 xxs of+      Right xs -> gfoldlVariant k z xs+      -- If the c@type variable in 'gfoldl' had a Functor constraint,+      -- this case could be extendVariant `fmap` gfoldl k z xs,+      -- and then 'GfoldlVariant' would be unnecessary+      Left x ->+            let mkV e = mkVariant (Label :: Label l) e Proxy+            in z mkV `k` x++instance (Unvariant '[a] v, a ~ Tagged l v, Data v,+          MkVariant l v b) => GfoldlVariant '[a] b where+    gfoldlVariant k z xxs = z mkV `k` unvariant xxs+        where mkV e = mkVariant (Label :: Label l) e Proxy++++-- --------------------------------------------------------------------------+-- * Map+-- | Apply a function to all possible elements of the variant+newtype HMapV f = HMapV f++-- | shortcut for @applyAB . HMapV@. 'hMap' is more general+hMapV f v = applyAB (HMapV f) v++-- | @hMapOutV f = unvariant . hMapV f@, except an ambiguous type+-- variable is resolved by 'HMapOutV_gety'+hMapOutV :: forall x y z f. (SameLength x y,+      HMapAux Variant (HFmap f) x y,+      Unvariant y z,+      HMapOutV_gety x z ~ y+  ) => f -> Variant x -> z+hMapOutV f v = unvariant (hMapV f v :: Variant y)+++-- | resolves an ambiguous type in 'hMapOutV'+type family HMapOutV_gety (x :: [*]) (z :: *) :: [*]+type instance HMapOutV_gety (Tagged s x ': xs) z = Tagged s z ': HMapOutV_gety xs z+type instance HMapOutV_gety '[] z = '[]+++-- | apply a function to all values that could be in the variant.+instance (vx ~ Variant x,+          vy ~ Variant y,+          HMapAux Variant (HFmap f) x y,+          SameLength x y)+     => ApplyAB (HMapV f) vx vy where+    applyAB (HMapV f) x = hMapAux (HFmap f) x++instance (ApplyAB f te te') => HMapAux Variant f '[te] '[te'] where+    hMapAux f v = case splitVariant1' v of+        Left te -> unsafeMkVariant 0 (applyAB f te :: te')+        Right _ -> error "HMapVAux: variant invariant broken"++instance (ApplyAB f te te',+          HMapCxt Variant f (l ': ls) (l' ': ls'))+    => HMapAux Variant f (te ': l ': ls) (te' ': l' ': ls') where+      hMapAux f v = case splitVariant1' v of+          Left te -> unsafeMkVariant 0 (applyAB f te :: te')+          Right es -> extendVariant (hMapAux f es)++-- --------------------------------------------------------------------------+-- * HUpdateAtLabel instance++{- |++> hUpdateAtLabel x e' (mkVariant x e proxy) == mkVariant x e' proxy+> hUpdateAtLabel y e' (mkVariant x e proxy) == mkVariant x e  proxy++-}+instance+   (HUpdateVariantAtLabelCxt l e v v' n _e) =>+    HUpdateAtLabel Variant l e v v' where+    hUpdateAtLabel l e v = case hLookupByLabel l v of+          Just _e -> mkVariant l e (Proxy :: Proxy v')+          Nothing -> unsafeCastVariant v++type HUpdateVariantAtLabelCxt l e v v' n _e =+   (HFindLabel l v n,+    HFindLabel l v' n,+    HUpdateAtHNatR n (Tagged l e) v ~ v',+    HasField l (Variant v) (Maybe _e),+    HasField l (Record v') e,+    MkVariant l e v')+++-- --------------------------------------------------------------------------+-- * HExtend instance+{- | Extension for Variants prefers the first value++> (l .=. Nothing) .*. v = v+> (l .=. Just e)  .*. _ = mkVariant l e Proxy++-}+instance (le ~ Tagged l (Maybe e), HOccursNot (Label l) (LabelsOf v)) =>+    HExtend le (Variant v) where+    type HExtendR le (Variant v) = Variant (UnMaybe le ': v)+    Tagged (Just e) .*. _ = unsafeMkVariant 0 e+    Tagged Nothing .*. (Variant n e) = Variant (n+1) e++type family UnMaybe le+type instance UnMaybe (Tagged l (Maybe e)) = Tagged l e++-- | used for 'HExtend' 'TIP'+type instance UnMaybe (Maybe e) = e+++-- --------------------------------------------------------------------------+-- * Conversion to an untagged value+class HAllEqVal (x :: [*]) (b :: Bool) | x -> b+instance HAllEqVal '[] True+instance HAllEqVal '[x] True+instance (HEq a a' b,+          HAllEqVal (Tagged t a' ': xs) b2,+          HAnd b b2 ~ b3) =>+  HAllEqVal (Tagged s a ': Tagged t a' ': xs) b3+++class HAllEqVal' (x :: [*])+instance HAllEqVal' '[]+instance HAllEqVal' '[x]+instance (HAllEqVal' (ta ': xs),+          a' ~ a,+          ta ~ Tagged t a,+          ta' ~ Tagged t' a')+  => HAllEqVal' (ta' ': ta ': xs)+++{- | Similar to 'unvariant', except type variables in @v@+will be made equal to @e@ if possible. That allows the type+of @Nothing@ to be inferred as @Maybe Char@.++>>> unvariant' $ x .=. Nothing .*. mkVariant1 y 'y'+'y'++However, this difference leads to more local error messages+(@Couldn't match type ‘()’ with ‘Char’@), rather than the following+with @unvariant@:++> Fail+>    '("Variant",+>      '[Tagged "left" Char, Tagged "right" ()],+>      "must have all values equal to ",+>      e))++-}+class Unvariant' v e | v -> e where+    unvariant' :: Variant v -> e++instance (HAllEqVal' (Tagged () e ': v), Unvariant v e) =>+    Unvariant' v e where+  unvariant' = unvariant++{- | Convert a Variant which has all possibilities having the same type+into a value of that type. Analogous to @either id id@.++See also 'unvariant'' -}+class Unvariant v e | v -> e where+    unvariant :: Variant v -> e++instance (Unvariant1 b v e,+          HAllEqVal v b,+          HAllEqVal (Tagged () e ': v) b)+    => Unvariant v e where+      unvariant = unvariant1 (Proxy :: Proxy b)+++class Unvariant1 b v e | b v -> e where+    unvariant1 :: Proxy b -> Variant v -> e++instance (v ~ Tagged t1 e)+    => Unvariant1 True (v ': vs) e where+    unvariant1 _ = unsafeUnVariant++data UnvariantTypeMismatch (vs :: [*])++instance Fail (UnvariantTypeMismatch (v ': vs))+      => Unvariant1 False (v ': vs) (UnvariantTypeMismatch (v ': vs)) where+    unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances"++instance Fail "Unvariant applied to empty variant"+      => Unvariant1 b '[] (Proxy "Unvariant applied to empty variant") where+    unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances"++{- | @Lens (Variant s) (Variant t) a b@++Analogue of @Control.Lens.chosen :: Lens (Either a a) (Either b b) a b@+-}+unvarianted :: (Unvariant' s a,+                Unvariant' t b,+                SameLabels s t, -- extra constraints to reduce ambiguity+                SameLength s t,+                Functor f) =>+    (a -> f b) -> Variant s -> f (Variant t)+unvarianted f v@(Variant n _) = fmap (\e' -> unsafeMkVariant n e')+                                      (f (unvariant' v))++-- | @Lens' (Variant s) a@+--+-- where we might have @s ~ '[Tagged t1 a, Tagged t2 a]@+unvarianted' x = simple (unvarianted x)++-- * Zip++{- | Applies to variants that have the same labels+in the same order. A generalization of++> zipEither :: Either a b -> Either a b -> Maybe (Either (a,a) (b,b))+> zipEither (Left a) (Left a') = Just (Left (a,a'))+> zipEither (Right a) (Right a') = Just (Right (a,a'))+> zipEither _ _ = Nothing++see 'HZip' for zipping other collections++-}+class ZipVariant x y xy | x y -> xy, xy -> x y where+    zipVariant :: Variant x -> Variant y -> Maybe (Variant xy)++instance ZipVariant '[] '[] '[] where+    zipVariant _ _ = Nothing++instance (tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y),+          ZipVariant xs ys zs,+          MkVariant t (x,y) (txy ': zs))+  => ZipVariant (tx ': xs) (ty ': ys) (txy ': zs) where+    zipVariant x y = case (splitVariant1 x, splitVariant1 y) of+        (Left x', Left y') -> Just (mkVariant (Label :: Label t) (x',y') Proxy)+        (Right x', Right y') -> extendVariant <$> zipVariant x' y'+        _ -> Nothing+++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))+      => HUnzip Variant (tx ': x2 ': xs) (ty ': y2 ': ys) (txy ': xy2 ': xys) where+    hUnzip xy = case splitVariant1 xy of+      Left (x,y) -> (mkVariant (Label :: Label t) x Proxy,+                     mkVariant (Label :: Label t) y Proxy)+      Right xy' | (x,y) <- hUnzip xy' ->+                    (extendVariant x,+                     extendVariant y)++instance (Unvariant '[txy] txy,+          tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y))+      => HUnzip Variant '[tx] '[ty] '[txy] where+    hUnzip xy | Tagged (x,y) <- unvariant xy =+        (mkVariant1 Label x, mkVariant1 Label y)+++-- ** with a record++{- | Apply a record of functions to a variant of values.+The functions are selected based on those having the same+label as the value.++-}+class (SameLength v v',+       SameLabels v v')  => ZipVR fs v v' | fs v -> v' where+    -- | 'zipVR' is probably a better choice in most+    -- situations, since it requires that @fs@ has one function for every+    -- element of @v@+    zipVR_ :: Record fs -> Variant v -> Variant v'++instance (lv ~ Tagged l v,+          lv' ~ Tagged l v',+          HMemberM (Label l) (LabelsOf fs) b,+          HasFieldM l (Record fs) f,+          DemoteMaybe (v -> v) f ~ (v -> v'),+          MkVariant l v' (lv' ': rs),+          ZipVR fs vs rs) =>+          ZipVR fs (lv ': vs) (lv' ': rs) where+    zipVR_ r lvs = case splitVariant1 lvs of+                  Left v | v' <- hLookupByLabelM l r (id :: v -> v) v -> mkVariant l v' Proxy+                  Right vs -> extendVariant $ zipVR_ r vs+      where l = Label :: Label l+++instance ZipVR fs '[] '[] where+    zipVR_ _ x = x++{- |++>>> let xy = x .*. y .*. emptyProxy+>>> let p = Proxy `asLabelsOf` xy+>>> let vs = [ mkVariant x 1.0 p, mkVariant y () p ]+++>>> zipVR (hBuild (+1) id) `map` vs+[V{x=2.0},V{y=()}]+++-}+zipVR :: (SameLabels fs v, SameLength fs v, ZipVR fs v v',+          ZipVRCxt fs v v')+    => Record fs -> Variant v -> Variant v'+zipVR = zipVR_+++{- | Lets 'zipVR' act as if @'ZipVR' fs v v'@ had an FD @v v' -> fs@++> ZipVRCxt [Tagged s f,  Tagged t g]+>          [Tagged s fx, Tagged t gx]+>          [Tagged s fy, Tagged t gy]+>   = (f ~ (fx -> fy), g ~ (gx -> gy))++-}+type family ZipVRCxt (fs :: [*]) (xs :: [*]) (ys :: [*]) :: Constraint++type instance ZipVRCxt (Tagged s f ': fs) (Tagged s x ': xs) (Tagged s y ': ys) =+        (f ~ (x -> y), ZipVRCxt fs xs ys)+type instance ZipVRCxt '[] '[] '[] = ()++-- * Eq+instance Eq (Variant '[]) where+  _ == _ = True++instance (Eq (Variant xs), Eq x) => Eq (Variant (x ': xs)) where+  v == v' = case (splitVariant1' v, splitVariant1' v') of+    (Left l, Left r) -> l == r+    (Right l, Right r) -> l == r+    _ -> False++-- ** Alternative Eq+-- | implemented like @and (zipWith (==) xs ys)@. Behaves the same as the Eq instances for 'Variant'+eqVariant v v' = maybe False (hMapOutV UncurryEq) $ zipVariant v v'++data UncurryEq = UncurryEq++instance (ee ~ (e,e), Eq e, bool ~ Bool) =>+    ApplyAB UncurryEq ee bool where+      applyAB _ (e,e') = e == e'++-- * Ord+instance Ord (Variant '[]) where+  compare _ _ = EQ++instance (Ord x, Ord (Variant xs)) => Ord (Variant (x ': xs)) where+  compare a b = compare (splitVariant1' a) (splitVariant1' b)++-- * Bounded+instance (Bounded x, Bounded z,+          HRevAppR (Tagged s x ': xs) '[] ~ (Tagged t z ': sx),+          MkVariant t z (Tagged s x ': xs))+        => Bounded (Variant (Tagged s x ': xs)) where+  minBound = mkVariant (Label :: Label s) (minBound :: x) Proxy+  maxBound = mkVariant (Label :: Label t) (maxBound :: z) Proxy++-- * Enum+{- |++>>> let t = minBound :: Variant '[Tagged "x" Bool, Tagged "y" Bool]+>>> [t .. maxBound]+[V{x=False},V{x=True},V{y=False},V{y=True}]+++[@Odd behavior@]+There are some arguments that this instance should not exist.++The last type in the Variant does not need to be Bounded. This+means that 'enumFrom' behaves a bit unexpectedly:++>>> [False .. ]+[False,True]++>>> [t .. ]+[V{x=False},V{x=True},V{y=False},V{y=True},V{y=*** Exception: Prelude.Enum.Bool.toEnum: bad argument++This is a \"feature\" because it allows an @Enum (Variant '[Tagged \"a\" Bool, Tagged \"n\" 'Integer'])@++Another difficult choice is that the lower bound is @fromEnum 0@ rather than @minBound@:++>>> take 5 [ minBound :: Variant '[Tagged "b" Bool, Tagged "i" Int] .. ]+[V{b=False},V{b=True},V{i=0},V{i=1},V{i=2}]++-}+instance (Enum x, Bounded x, Enum (Variant (y ': z))) => Enum (Variant (Tagged s x ': y ': z)) where+  fromEnum v = case splitVariant1 v of+    Left x -> fromEnum x+    Right yz -> 1 + fromEnum (maxBound :: Tagged s x) + fromEnum yz++  toEnum n+      | m >= n = mkVariant (Label :: Label s) (toEnum n) Proxy+      | otherwise = extendVariant $ toEnum (n - m - 1)+    where m = fromEnum (maxBound :: Tagged s x)++{- |++While the instances could be written Enum (Variant '[])+Eq/Ord which cannot produce values, so they have instances for+empty variants ('unsafeEmptyVariant'). Enum can produce values,+so it is better that @fromEnum 0 :: Variant '[]@ fails with No instance for+@Enum (Variant '[])@ than producing an invalid variant.++-}+instance Enum x => Enum (Variant '[Tagged s x]) where+  fromEnum v = case splitVariant1 v of+    Left x -> fromEnum x+    _ -> error "Data.HList.Variant fromEnum impossible"+  toEnum n = mkVariant (Label :: Label s) (toEnum n) Proxy++-- * Ix (TODO)++-- * Semigroup+instance (Unvariant '[Tagged t x] x, Semigroup x) => Semigroup (Variant '[Tagged t x]) where+    a <> b = case (unvariant a, unvariant b) of+                    (l, r) -> mkVariant (Label :: Label t) (l <> r) Proxy++instance (Semigroup x, Semigroup (Variant (a ': b))) => Semigroup (Variant (Tagged t x ': a ': b)) where+    a <> b = case (splitVariant1 a, splitVariant1 b) of+                    (Left l, Left r) -> mkVariant (Label :: Label t) (l <> r) Proxy+                    (Left l, _) -> mkVariant (Label :: Label t) l Proxy+                    (_, Left r) -> mkVariant (Label :: Label t) r Proxy+                    (Right l, Right r) -> extendVariant $ l <> r++-- * Monoid+instance (Unvariant '[Tagged t x] x, Monoid x) => Monoid (Variant '[Tagged t x]) where+    mempty = mkVariant (Label :: Label t) mempty Proxy+#if __GLASGOW_HASKELL__ <= 906+    mappend a b = case (unvariant a, unvariant b) of+                    (l, r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+#endif+++instance (Monoid x, Monoid (Variant (a ': b))) => Monoid (Variant (Tagged t x ': a ': b)) where+    mempty = extendVariant mempty+#if __GLASGOW_HASKELL__ <= 906+    mappend a b = case (splitVariant1 a, splitVariant1 b) of+                    (Left l, Left r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+                    (Left l, _) -> mkVariant (Label :: Label t) l Proxy+                    (_, Left r) -> mkVariant (Label :: Label t) r Proxy+                    (Right l, Right r) -> extendVariant $ mappend l r+#endif++-- * Projection++{- | convert a variant with more fields into one with fewer (or the same)+fields.+++>>> let ty = Proxy :: Proxy [Tagged "left" Int, Tagged "right" Int]+>>> let l = mkVariant _left 1 ty+>>> let r = mkVariant _right 2 ty+++>>> map projectVariant [l, r] :: [Maybe (Variant '[Tagged "left" Int])]+[Just V{left=1},Nothing]+++@'rearrangeVariant' = 'fromJust' . 'projectVariant'@ is one implementation+of 'rearrangeVariant', since the result can have the same fields with+a different order:++>>> let yt = Proxy :: Proxy [Tagged "right" Int, Tagged "left" Int]++>>> map projectVariant [l, r] `asTypeOf` [Just (mkVariant _left 0 yt)]+[Just V{left=1},Just V{right=2}]+++-}+class ProjectVariant x y where+    projectVariant :: Variant x -> Maybe (Variant y)++instance (ProjectVariant x ys,+          HasField t (Variant x) (Maybe y),+          HOccursNot (Label t) (LabelsOf ys),+          ty ~ Tagged t y)+  => ProjectVariant x (ty ': ys) where+    projectVariant x = y `mplus` ys+      where t = Label :: Label t+            y = (\v -> mkVariant t v Proxy) <$> x .!. t+            ys = (mty  .*.) <$> (projectVariant x :: Maybe (Variant ys))+            mty = Tagged Nothing :: Tagged t (Maybe y)++instance ProjectVariant x '[] where+    projectVariant _ = Nothing++++{- | @projectExtendVariant = fmap 'extendVariant' . 'projectVariant'@++where intermediate variant is as large as possible. Used to implement+"Data.HList.Labelable".'projected'++Note that:++>>> let r = projectExtendVariant (mkVariant1 Label 1 :: Variant '[Tagged "x" Int])+>>> r :: Maybe (Variant '[Tagged "x" Integer])+Nothing++-}+class HAllTaggedLV y => ProjectExtendVariant x y where+    projectExtendVariant :: Variant x -> Maybe (Variant y)++instance HAllTaggedLV y => ProjectExtendVariant '[] y where+    projectExtendVariant _ = Nothing++instance (lv ~ Tagged l v,+          HMemberM lv y inY,+          ProjectExtendVariant' inY lv y,+          ProjectExtendVariant xs y+      ) => ProjectExtendVariant (lv ': xs) y where+  projectExtendVariant v = case splitVariant1' v of+      Left lv -> projectExtendVariant' (Proxy :: Proxy inY) lv+      Right v' -> projectExtendVariant v'+++class ProjectExtendVariant' (inY :: Maybe [*]) lv (y :: [*]) where+    projectExtendVariant' :: Proxy inY -> lv -> Maybe (Variant y)++instance ProjectExtendVariant' Nothing lv y where+    projectExtendVariant' _ _ = Nothing++instance (MkVariant l v y, lv ~ Tagged l v) => ProjectExtendVariant' (Just t) lv y where+    projectExtendVariant' _ (Tagged v) = Just (mkVariant (Label :: Label l) v Proxy)++++class (ProjectVariant x yin,+       ProjectVariant x yout) => SplitVariant x yin yout where+    splitVariant :: Variant x -> Either (Variant yin) (Variant yout)++instance+   (-- implementation+    ProjectVariant x yin,+    ProjectVariant x yout,++    -- constraints to ensure exactly one of+    -- the uses of projectVariant gives a Just+    H2ProjectByLabels (LabelsOf yin) x xi xo,+    HRearrange (LabelsOf yin) xi yin,+    HRearrange (LabelsOf yout) xo yout,++    HLeftUnion xi xo xixo,+    HRearrange (LabelsOf x) xixo x,++    -- probably redundant+    HAllTaggedLV x, HAllTaggedLV yin, HAllTaggedLV yout) =>+  SplitVariant x yin yout where+  splitVariant x = case (projectVariant x, projectVariant x) of+   (Nothing, Just yout) -> Right yout+   (Just yin, Nothing) -> Left yin+   _ -> error "Data.HList.Variant:splitVariant impossible"++-- | @projectVariant . extendsVariant = Just@ (when the types match up)+--+-- 'extendVariant' is a special case+class (HAllTaggedLV y, HAllTaggedLV x) => ExtendsVariant x y where+    extendsVariant :: Variant x -> Variant y++instance (MkVariant l e y, le ~ Tagged l e,+          ExtendsVariant (b ': bs) y) => ExtendsVariant (le ': b ': bs) y where+    extendsVariant v = case splitVariant1 v of+        Left e -> mkVariant (Label :: Label l) (e :: e) Proxy+        Right vs -> extendsVariant vs++instance (HAllTaggedLV x, Unvariant '[le] e, MkVariant l e x,+          le ~ Tagged l e) => ExtendsVariant '[le] x where+    extendsVariant v = mkVariant (Label :: Label l) (unvariant v) Proxy+++-- | @rearrangeVariant@ is a specialization of 'extendsVariant' whose+-- result is always . see also 'rearranged'+rearrangeVariant :: (SameLength v v', ExtendsVariant v v')+      => Variant v -> Variant v'+rearrangeVariant v = extendsVariant v++instance (SameLength s a, ExtendsVariant s a,+          SameLength b t, ExtendsVariant b t) => Rearranged Variant s t a b+  where+    rearranged = iso rearrangeVariant rearrangeVariant++-- | @Prism (Record tma) (Record tmb) (Variant ta) (Variant tb)@+--+-- see 'hMaybied''+hMaybied x = prism variantToHMaybied+    (\s -> case hMaybiedToVariants s of+          [a] -> Right a+          _ -> Left (hMapR HCastF s))+    x+++data HCastF = HCastF++instance (mx ~ Maybe x,+          my ~ Maybe y,+          HCast y x) =>+  ApplyAB HCastF mx my where+    applyAB _ x = hCast =<< x++++{- | @Prism' (Record tma) (Variant ta)@++where @tma@ and @tmb@ are lists like++> tma ~ '[Tagged x (Maybe a), Tagged y (Maybe b)]+> ta  ~ '[Tagged x        a , Tagged y        b ]++If one element of the record is Just, the Variant will+contain that element. Otherwise, the prism fails.++[@Note@]++The types work out to define a prism:++@l = 'prism'' 'variantToHMaybied' ('listToMaybe' . 'hMaybiedToVariants')@++but the law: @s^?l ≡ Just a ==> l # a ≡ s@ is not followed,+because we could have:++@+  s, s2 :: Record '[Tagged "x" (Maybe Int), Tagged "y" (Maybe Char)]+  s = hBuild (Just 1) (Just '2')+  s2 = hBuild (Just 1) Nothing++  v :: Variant '[Tagged "x" Int, Tagged "y" Char]+  v = mkVariant (Label :: Label "x") 1 Proxy+@++So that @s^?l == Just v@. But @l#v == s2 /= s@, while the law+requires @l#v == s@. hMaybied avoids this problem by only+producing a value when there is only one present.++-}+hMaybied' x = simple (hMaybied (simple x))++class VariantToHMaybied v r | v -> r, r -> v where+    variantToHMaybied :: Variant v -> Record r++instance VariantToHMaybied '[] '[] where+    variantToHMaybied _ = emptyRecord++instance (VariantToHMaybied v r,+          HReplicateF nr ConstTaggedNothing () r,++          tx ~ Tagged t x,+          tmx ~ Tagged t (Maybe x))+    => VariantToHMaybied (tx ': v) (tmx ': r) where+      variantToHMaybied v = case splitVariant1 v of+            Left x -> Record+                $ HCons (Tagged (Just x))+                $ hReplicateF Proxy ConstTaggedNothing ()+            Right rest ->+                case variantToHMaybied rest of+                  Record a -> Record $ (Tagged Nothing :: Tagged t (Maybe x)) `HCons` a+          -- don't use (.*.) because we have (LabelsOf v ~ LabelsOf r), so+          -- the duplicate check (HRLabelSet) implied by (.*.) is redundant++data ConstTaggedNothing = ConstTaggedNothing+instance (y ~ Tagged t (Maybe e)) => ApplyAB ConstTaggedNothing x y where+    applyAB _ _ = Tagged Nothing++-- | Every element of the record that is Just becomes one element+-- in the resulting list. See 'hMaybied'' example types that @r@+-- and @v@ can take.+hMaybiedToVariants ::+  (HFoldr HMaybiedToVariantFs [Variant '[]] r [Variant v], -- impl+   VariantToHMaybied v r -- evidence for typechecking+  ) => Record r -> [Variant v]+hMaybiedToVariants (Record r) = hFoldr HMaybiedToVariantFs ([] :: [Variant '[]]) r++data HMaybiedToVariantFs = HMaybiedToVariantFs++instance (x ~ (Tagged t (Maybe e), [Variant v]),+          y ~ [Variant (Tagged t e ': v)],+          MkVariant t e (Tagged t e ': v))+        => ApplyAB HMaybiedToVariantFs x y where++  applyAB _ (Tagged me, v) = case me of+    Just e -> mkVariant (Label :: Label t) e Proxy : map extendVariant v+    _ -> fmap extendVariant v
− Data/HList/broken/Label5.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}--{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Yet another model of labels.--   This model allow us to use any type as label type.-   As a result, we need some generic instances.--   Also, type errors may be more confusing now.--}--module Data.HList.Label5 where--import Data.Typeable-import Data.Char-import Data.HList.FakePrelude-import Data.HList.Record----- | Equality on labels---- instance TypeEq x y b => HEq x y b----- | Show label--instance Typeable x => ShowLabel x- where-  showLabel = (\(x:xs) -> toLower x:xs)-            . reverse-            . takeWhile (not . (==) '.')-            . reverse-            . show-{--            . tyConString-            . typeRepTyCon--}-            . typeOf
Data/HList/broken/RecordAdv.hs view
@@ -32,8 +32,6 @@ -- -- Replace a proxy by a value of the proxied type. -- The signature is inferred-hUnproxyLabel :: (HFind l (RecordLabels r) n,HUpdateAtHNat n (LVPair l v) r,HasField l (Record r) (Proxy v)) =>-    Label l-> v -> Record r -> Record (HUpdateAtHNatR n (LVPair l v) r) hUnproxyLabel l v r = hUpdateAtLabel l v r  where   tpe :: a -> Proxy a -> ()@@ -45,8 +43,7 @@ {-|   This is a variation on updating, so use the same fixity as (.\@.). -}-f@(LVPair v) .^. r = hUnproxyLabel (labelLVPair f) v r-+f@(Tagged v) .^. r = hUnproxyLabel (labelLVPair f) v r  -- -------------------------------------------------------------------------- @@ -61,10 +58,11 @@ class HasNoProxies (l :: [*]) instance HasNoProxies '[] instance Fail (ProxyFound x) => HasNoProxies (Proxy x ': l)-instance Fail (ProxyFound x) => HasNoProxies (LVPair lab (Proxy x) ': l)+instance Fail (ProxyFound x) => HasNoProxies (Tagged lab (Proxy x) ': l) instance HasNoProxies l => HasNoProxies (e ': l)  + -- --------------------------------------------------------------------------  -- | Narrow a record to a different record type@@ -75,16 +73,16 @@ class  NarrowM a b res | a b -> res where     narrowM :: Record a -> Record b -> res -instance NarrowM a '[] (HJust (Record '[])) where+instance res ~ HJust (Record '[]) => NarrowM a '[] res where      narrowM _ _ = HJust emptyRecord  instance (H2ProjectByLabels (l ': '[]) a rin rout,           NarrowM' rin rout b res)-    => NarrowM a (LVPair l v ': b) res where+    => NarrowM a (Tagged l v ': b) res where     narrowM (Record a) _ = narrowM' (Record rin) (Record rout) (undefined:: Record b)      where-        (rin,rout) = h2projectByLabels (proxy :: Proxy (l ': '[])) a+        (rin,rout) = h2projectByLabels (Proxy :: Proxy (l ': '[])) a  -- | could be changed to type family class  NarrowM' rin rout b res | rin rout b -> res where@@ -99,10 +97,10 @@     narrowM' (Record (f `HCons` HNil)) rout b =         narrowM'' f (narrowM rout b) -class  NarrowM'' f r r' where+class  NarrowM'' f r r' | f r -> r' where     narrowM'' :: f -> r -> r' -instance (hNothing ~ HNothing) => NarrowM'' f HNothing hNothing where+instance NarrowM'' f HNothing HNothing where     narrowM'' _ _ = HNothing  instance NarrowM'' f (HJust (Record r)) (HJust (Record (f ': r))) where@@ -116,10 +114,10 @@  where   narrow _ = emptyRecord  instance ( Narrow rout r'-         , H2ProjectByLabels (l ': '[]) r (LVPair l v ': '[]) rout-         ) => Narrow r ( LVPair l v ': r' )+         , H2ProjectByLabels (l ': '[]) r (Tagged l v ': '[]) rout+         ) => Narrow r ( Tagged l v ': r' )   where-    narrow (Record r) = case h2projectByLabels (proxy::Proxy (l ': '[])) r of+    narrow (Record r) = case h2projectByLabels (Proxy::Proxy (l ': '[])) r of         (HCons f HNil,rout) -> let (Record r')    = narrow (Record rout)             in Record (HCons f r') @@ -132,7 +130,7 @@  where   lubNarrow :: Record a -> Record b -> (Record c, Record c) -instance ( HTIntersect (RecordLabels a) (RecordLabels b) lc+instance ( HTIntersect (LabelsOf a) (LabelsOf b) lc          , H2ProjectByLabels lc a c aout          , H2ProjectByLabels lc b c bout          , HRLabelSet c@@ -141,16 +139,16 @@  where   lubNarrow ra@(Record _) rb@(Record _) =-     ( hProjectByLabels (proxy::Proxy lc) ra-     , hProjectByLabels (proxy::Proxy lc) rb+     ( hProjectByLabels (Proxy::Proxy lc) ra+     , hProjectByLabels (Proxy::Proxy lc) rb      )  -{- -- --------------------------------------------------------------------------  -- | List constructors that also LUB together +{- data NilLub nilLub :: NilLub nilLub = undefined@@ -176,33 +174,32 @@  class HLub l e | l -> e  where-  hLub :: l -> [e]+  hLub :: HList l -> [e]  instance ( LubNarrow h h' e          )-      => HLub (HCons h (HCons h' HNil)) e+      => HLub [h,h'] e  where   hLub (HCons h (HCons h' _)) = [fst ee, snd ee]    where     ee = lubNarrow h h' -instance ( HLub (HCons h (HCons h'' t)) e'-         , HLub (HCons h' (HCons h'' t)) e''+instance ( HLub (h ': h'' ': t) e'+         , HLub (h' ': h'' ': t) e''          , LubNarrow e' e'' e-         , HLub (HCons e (HCons h'' t)) e+         , HLub (e ': h'' ': t) e          )-      => HLub (HCons h (HCons h' (HCons h'' t))) e+      => HLub (h ': h' ': h'' ': t) e  where-  hLub (HCons h (HCons h' t)) = fst e : ( snd e : tail r )+  hLub (HCons h (HCons h' t)) = fst e : snd e : tail r    where     e' = hLub (HCons h t)     e'' = hLub (HCons h' t)     e = lubNarrow (head e') (head e'')     r = hLub (HCons (fst e) t)+    -}  --}- -- -------------------------------------------------------------------------- -- | Record equivalence modulo field order --@@ -227,13 +224,13 @@ -- field uniquely determines the type of the field value. Therefore, we -- should not use equivR on two records with inconsistent labeling... -class RecordEquiv r1 r2 res | r1 r2 -> res where+class RecordEquiv r1 r2 res where     equivR :: r1 -> r2 -> res   instance (HEq r1 r2 b, RecordEquiv' b r1 r2 res)     => RecordEquiv r1 r2 res where-    equivR _ _ = equivR' (undefined::Proxy b) (undefined::r1) (undefined::r2)+    equivR _ _ = equivR' (Proxy::Proxy b) (undefined::r1) (undefined::r2) -- Two records have the same type: the fast path instance RecordEquiv' True r r                       (HJust (r->r,r->r)) where@@ -242,14 +239,15 @@ instance (NarrowM r1 r2 r12, NarrowM r2 r1 r21,           RecordEquiv' False (Record r1->r12) (Record r2->r21) res)     => RecordEquiv (Record r1) (Record r2) res where-    equivR r1 r2 = equivR' (undefined :: Proxy False) r1p r2p+    equivR r1 r2 = equivR' (Proxy :: Proxy False) r1p r2p      where r1p r1 = narrowM (r1 :: Record r1) r2            r2p r2 = narrowM (r2 :: Record r2) r1  class RecordEquiv' (b :: Bool) pj1 pj2 res | b pj1 pj2 -> res where     equivR' :: Proxy b -> pj1 -> pj2 -> res -instance RecordEquiv' False (r1->HJust r2) (r2->HJust r1) (HJust (r1->r2,r2->r1))+instance res ~ HJust (r1->r2,r2->r1) =>+      RecordEquiv' False (r1->HJust r2) (r2->HJust r1) res     where     equivR' _ r12 r21 = HJust (unj.r12,unj.r21)      where unj (HJust x) = x@@ -262,45 +260,9 @@ instance RecordEquiv' False (r1->HJust r2) (r2->HNothing) HNothing where     equivR' _ _ _ = HNothing -{-  -- ----------------------------------------------------------------------------- Typeable instances--hNilTcName :: TyCon-hNilTcName = mkTyCon "HList.HNil"-instance Typeable HNil- where-  typeOf _ = mkTyConApp hNilTcName []--hConsTcName :: TyCon-hConsTcName = mkTyCon "HList.HCons"-instance (Typeable x, Typeable y) => Typeable (HCons x y)- where-  typeOf ~(HCons x y)-   = mkTyConApp hConsTcName [ typeOf x, typeOf y ]--recordTcName :: TyCon-recordTcName = mkTyCon "HList.Record"-instance Typeable x => Typeable (Record x)- where-  typeOf ~(Record x)-   = mkTyConApp recordTcName [ typeOf x ]--hFieldTcName :: TyCon-hFieldTcName = mkTyCon "HList.F"-instance (Typeable x, Typeable y) => Typeable (LVPair x y)- where-  typeOf _-   = mkTyConApp hFieldTcName [ typeOf (undefined::x), typeOf (undefined::y)  ]--proxyTcName :: TyCon-proxyTcName = mkTyCon "HList.Proxy"-instance Typeable x => Typeable (Proxy x)- where-  typeOf _-   = mkTyConApp proxyTcName [ typeOf (undefined::x) ]-+-- * Typeable instances+-- TODO: see Data.HList.Data --}
+ Data/HList/broken/RecordOrd.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+-- | records with Symbol labels that are sorted. Not enabled yet+-- because CmpSymbol comes with ghc>=7.8 and ghc-7.6 is not dropped yet+module Data.HList.RecordOrd where++import Data.HList.HList+import Data.HList.HListPrelude+import Data.HList.FakePrelude+import Data.Tagged++import GHC.TypeLits+import Data.Type.Equality++import Data.HList.Record++-- two-class version+class InsertOrd1 kv l l' | kv l -> l' where+    insertOrd1 :: kv -> HList l -> HList l'++class InsertOrd2 (b :: Ordering) kv l l' | b kv l -> l' where+    insertOrd2 :: Proxy b -> kv -> HList l -> HList l'+++instance InsertOrd2 LT kv l (kv ': l) where+    insertOrd2 _ kv l = HCons kv l++instance (x ~ (l1 ': rest),+          y ~ (l1 ': rest'),+          InsertOrd1 kv rest rest') => InsertOrd2 GT kv x y where+    insertOrd2 _ kv (HCons l1 rest) = HCons l1 (insertOrd1 kv rest)+    insertOrd2 _ _ _ = error "Data.HList.RecordOrd: ghc bug"+++instance Fail (DuplicatedLabel kv) => InsertOrd2 EQ kv x '[DuplicatedLabel kv] where+    insertOrd2 _ _ _ = error "Data.HList.RecordOrd: there must be no instances of Fail"+++instance (  b ~ CmpSymbol k k',+            taggedkv ~ Tagged k v,+            taggedk'v' ~ Tagged k' v',+            InsertOrd2 b taggedkv (taggedk'v' ': kvs) kvs')+          => InsertOrd1 taggedkv (taggedk'v' ': kvs) kvs' where+    insertOrd1 kv kvs = insertOrd2 (Proxy :: Proxy b) kv kvs++instance InsertOrd1 x '[] '[x] where+    insertOrd1 kv _ = HCons kv HNil++data InsertOrd = InsertOrd+instance (x ~ (e, HList r),+          InsertOrd1 e r r',+          y ~ HList r'+        )=> ApplyAB InsertOrd x y where+  applyAB _ (e,r) = insertOrd1 e r++hSort' xs = hFoldr InsertOrd HNil xs+++class HSorted (r :: [*])++instance HSorted '[]+instance HSorted '[x]+instance (HSorted (ty ': rest),+          tx ~ Tagged x vx,+          ty ~ Tagged y vy,+          CmpSymbol x y ~ LT) +      => HSorted (tx ': ty ': rest)+++{-++In principle this could be an appropriate proxy to use+for Variant: once the field ordering and number of fields+is fixed, as it would be for++_left = Label :: Label "left"+_right = Label :: Label "right"++(v,w) = case sortedProxyLen (hSucc (hSucc hZero)) of+              e -> (mkVariant _left 'x' e,+                    mkVariant _right (5 :: Int) e)++Then:++v :: (HasField' b1 "right" '[Tagged x a, Tagged y a1] Int,+      HasField' b "left" '[Tagged x a, Tagged y a1] Char,+      HFind2 b1 "right" '[y] n1, HFind2 b "left" '[y] n,+      HNat2Integral n1, HNat2Integral n, HEq "right" x b1,+      HEq "left" x b, GHC.TypeLits.CmpSymbol x y ~ 'LT) =>+     Variant '[Tagged x a, Tagged y a1]++Does not reduce to v :: Variant '[Tagged "left" Char, Tagged "right" Int]++If only ghc would backtrack after trying (x ~ "left") or (y ~ "right")+and see that only one will satisfy @CmpSymbol x y ~ LT@,+++-}+sortedProxyLen :: (HSorted r,+                   SameLength' (HReplicateR n ()) r_,+                   HMapCxt (HFmap (Fun '[] ())) r r_) +        => Proxy n -> Proxy r+sortedProxyLen _ = Proxy++class HSort xs xs' where+    hSort :: SameLength xs xs' => Record xs -> Record xs'++instance HFoldr InsertOrd (HList '[]) xs (HList xs') => HSort xs xs' where+    hSort (Record xs) = Record (hSort' xs)++{- two type family version+type family InsertOrd1 kv kvs where+  InsertOrd1 kv '[] = '[kv]+  InsertOrd1 (Tagged k v) (Tagged k' v' ': kvs) =+      InsertOrd2+        (CmpSymbol k k')+        (Tagged k v)+        (Tagged k' v' ': kvs)++type family InsertOrd2 (b :: Ordering) (kv :: *) (kvs :: [*]) where+  InsertOrd2 b x '[] = '[x]+  InsertOrd2 GT (Tagged k v) (Tagged k' v' ': kvs) =+          InsertOrd1 (Tagged k v) (Tagged k' v' ': kvs)+  InsertOrd2 LT kv kvs = kv ': kvs+  InsertOrd2 EQ kv kvs = Err (DuplicatedLabel kv) '[]++-- | Error messages: http://www.haskell.org/pipermail/haskell-cafe/2013-November/111549.html+type family Err (x::k) (a :: j) :: j where+   Err x a = Err x (Err "infinite loop to bring this to your attention: don't raise the context stack please" a)+-}+++{-++-- Narrowing records+class (HRLabelSet a, HRLabelSet b) => Narrow a b where+    narrow :: Record a -> Record b++instance (HRLabelSet a,+          HRLabelSet b,+          HRLabelSet bOut,+          H2ProjectByLabels (RecordLabels b :: [k]) a b bOut)+      => Narrow a b where+    narrow a = case hProjectByLabels2 (Proxy :: Proxy (RecordLabels b :: [k])) a+      of (b :: Record b, _bOut :: Record bOut) -> b+      -}
Data/HList/broken/RecordP.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}@@ -33,23 +34,18 @@ -- -------------------------------------------------------------------------- -- Record types as Phantom labels with values -newtype RecordP (ls::[*]) vs = RecordP (HList vs)+newtype RecordP (ls::[k]) vs = RecordP (HList vs)   -- Build a record. I wonder if the 'ls' argument of mkRecordP can be -- removed. So far, we had no need for it... -mkRecordP :: (HSameLength ls vs, HLabelSet ls) => ls -> vs -> RecordP ls vs+mkRecordP :: (SameLength ls vs, HLabelSet ls) => proxy ls -> HList vs -> RecordP ls vs mkRecordP _ vs = RecordP vs --- The contraint that two type level lists have the same length-class HSameLength l1 l2-instance HSameLength '[] '[]-instance HSameLength l1 l2 => HSameLength (e1 ': l1) (e2 ': l2)- -- Build an empty record emptyRecordP :: RecordP ('[]) ('[])-emptyRecordP = mkRecordP HNil HNil+emptyRecordP = mkRecordP Proxy HNil  -- Converting between RecordP and Record (label/value pairs) @@ -62,16 +58,14 @@     record_r2p _ = emptyRecordP     record_p2r _ = emptyRecord -{--instance (RecordR2P r ls vs, HRLabelSet (HCons (LVPair l v) r),-          HLabelSet (HCons l ls), HSameLength ls vs)-    => RecordR2P (HCons (LVPair l v) r) (HCons l ls) (HCons v vs) where-    record_r2p (Record (HCons f r)) = hExtend f (record_r2p (Record r))-    record_p2r (RecordP (HCons v r)) = hExtend (LVPair v) (record_p2r (RecordP r))--labels_of_recordp :: RecordP ls vs -> ls-labels_of_recordp = undefined+instance (RecordR2P r ls vs, HRLabelSet (Tagged l v ': r),+          HLabelSet (l ': ls), SameLength ls vs)+    => RecordR2P (Tagged l v ': r) (l ': ls) (v ': vs) where+    record_r2p (Record (HCons f r)) = f  .*. record_r2p (Record r)+    record_p2r (RecordP (HCons v r)) = Tagged v .*. record_p2r (RecordP r) +labels_of_recordp :: RecordP ls vs -> Proxy ls+labels_of_recordp _ = Proxy  -- -------------------------------------------------------------------------- -- A Show instance to appeal to normal records@@ -85,24 +79,29 @@ -- -------------------------------------------------------------------------- -- Extension for records -instance (HLabelSet (HCons l ls), HSameLength ls vs)-    => HExtend (LVPair l v) (RecordP ls vs) (RecordP (HCons l ls) (HCons v vs))+instance (HLabelSet (l ': ls), SameLength ls vs)+    => HExtend (Tagged l v) (RecordP ls vs)  where-  hExtend (LVPair v) (RecordP vs) = mkRecordP undefined (HCons v vs)+  type HExtendR (Tagged l v) (RecordP ls vs) = RecordP (l ': ls) (v ': vs)+  Tagged v .*. RecordP vs = mkRecordP Proxy (HCons v vs)  + -- -------------------------------------------------------------------------- -- Record concatenation  instance ( HLabelSet ls''-         , HAppend ls ls' ls''-         , HAppend vs vs' vs''-         , HSameLength ls'' vs''+         , HAppendR (RecordP ls vs) (RecordP ls' vs') ~ RecordP ls'' vs''+         , HAppendList ls ls' ~ ls''+         , HAppendList vs vs' ~ vs''+         , SameLength ls'' vs''          )-    => HAppend (RecordP ls vs) (RecordP ls' vs') (RecordP ls'' vs'')+    => HAppend (RecordP ls vs) (RecordP ls' vs')  where-  hAppend (RecordP vs) (RecordP vs') = mkRecordP undefined (hAppend vs vs')+  hAppend (RecordP vs) (RecordP vs') = mkRecordP Proxy (hAppend vs vs') +type instance HAppendR (RecordP ls vs) (RecordP ls' vs') = RecordP (HAppendR ls ls') (HAppendR vs vs')+ -- -------------------------------------------------------------------------- -- Lookup operation @@ -110,22 +109,23 @@ -- implement it separately. The algorithm is familiar assq, -- only the comparison operation is done at compile-time -instance (HEq l l' b, HasFieldP' b l (RecordP (HCons l' ls) vs) v)-    => HasField l (RecordP (HCons l' ls) vs) v where-    hLookupByLabel = hLookupByLabelP' (undefined::b)+instance (HEq l l' b, HasFieldP' b l (l' ': ls) vs v)+    => HasField l (RecordP (l' ': ls) vs) v where+    hLookupByLabel = hLookupByLabelP' (Proxy :: Proxy b) -class HasFieldP' b l r v | b l r -> v where-    hLookupByLabelP' :: b -> l -> r -> v+class HasFieldP' b l ls vs v | b l ls vs -> v where+    hLookupByLabelP' :: Proxy b -> Label l -> RecordP ls vs -> v -instance HasFieldP' HTrue l (RecordP (HCons l ls) (HCons v vs)) v where+instance HasFieldP' True l (l ': ls) (v ': vs) v where     hLookupByLabelP' _ _ (RecordP (HCons v _)) = v  instance HasField l (RecordP ls vs) v-    => HasFieldP' HFalse l (RecordP (HCons l' ls) (HCons v' vs)) v where+    => HasFieldP' False l (l' ': ls) (v' ': vs) v where     hLookupByLabelP' _ l (RecordP (HCons _ vs)) =         hLookupByLabel l ((RecordP vs)::RecordP ls vs)  +{- -- -------------------------------------------------------------------------- -- Delete operation hDeleteAtLabelP :: HProjectByLabelP l ls vs lso v vso =>@@ -140,6 +140,7 @@ hUpdateAtLabelP l v rp@(RecordP vs) = RecordP (hUpdateAtHNat n v vs)  where   n       = hFind l (labels_of_recordp rp)+-}  -- -------------------------------------------------------------------------- -- Projection for records@@ -148,21 +149,21 @@  -- Project by a single label class HProjectByLabelP l ls vs lso v vso | l ls vs -> lso v vso where-    h2ProjectByLabelP :: l -> RecordP ls vs -> (v,RecordP lso vso)+    h2ProjectByLabelP :: Label l -> RecordP ls vs -> (v,RecordP lso vso) -instance (HEq l l' b, HProjectByLabelP' b l (HCons l' ls) vs lso v vso)-    => HProjectByLabelP l (HCons l' ls) vs lso v vso where-    h2ProjectByLabelP = h2ProjectByLabelP' (undefined::b)+instance (HEq l l' b, HProjectByLabelP' b l (l' ': ls) vs lso v vso)+    => HProjectByLabelP l (l' ': ls) vs lso v vso where+    h2ProjectByLabelP = h2ProjectByLabelP' (Proxy :: Proxy b)  class HProjectByLabelP' b l ls vs lso v vso | b l ls vs -> lso v vso where-    h2ProjectByLabelP' :: b -> l -> RecordP ls vs -> (v,RecordP lso vso)+    h2ProjectByLabelP' :: Proxy b -> Label l -> RecordP ls vs -> (v,RecordP lso vso) -instance HProjectByLabelP' HTrue l (HCons l ls) (HCons v vs) ls v vs where+instance HProjectByLabelP' True l (l ': ls) (v ': vs) ls v vs where     h2ProjectByLabelP' _ _ (RecordP (HCons v vs)) = (v,RecordP vs)  instance (HProjectByLabelP l ls vs lso' v vso')-    => HProjectByLabelP' HFalse l (HCons l' ls) (HCons v' vs)-       (HCons l' lso') v (HCons v' vso') where+    => HProjectByLabelP' False l (l' ': ls) (v' ': vs)+       (l' ': lso') v (v' ': vso') where     h2ProjectByLabelP' _ l (RecordP (HCons v' vs)) =         let (v,RecordP vso) = h2ProjectByLabelP l ((RecordP vs)::RecordP ls vs)         in (v, RecordP (HCons v' vso))@@ -173,34 +174,36 @@ -- classes H2ProjectByLabels and H2ProjectByLabels' are declared in -- Record.hs -instance H2ProjectByLabels (HCons l ls)-                           (RecordP HNil HNil) (RecordP HNil HNil)-                           (RecordP HNil HNil)+{- need to change H2ProjectByLabels kind variables back to * from [*]+instance H2ProjectByLabels (l ': ls)+                           (RecordP '[] '[]) (RecordP '[] '[])+                           (RecordP '[] '[])     where     h2projectByLabels _ _ = (emptyRecordP,emptyRecordP)  instance (HMember l' ls b,-          H2ProjectByLabels' b ls (RecordP (HCons l' ls') vs') rin rout)-    => H2ProjectByLabels ls (RecordP (HCons l' ls') vs') rin rout where-    h2projectByLabels = h2projectByLabels' (undefined::b)+          H2ProjectByLabels' b ls (RecordP (l' ': ls') vs') rin rout)+    => H2ProjectByLabels ls (RecordP (l' ': ls') vs') rin rout where+    h2projectByLabels = h2projectByLabels' (Proxy :: Proxy b)  instance H2ProjectByLabels ls (RecordP ls' vs') (RecordP lin vin) rout =>-    H2ProjectByLabels' HTrue ls (RecordP (HCons l' ls') (HCons v' vs'))-                             (RecordP (HCons l' lin) (HCons v' vin)) rout where+    H2ProjectByLabels' True ls (RecordP (l' ': ls') (v' ': vs'))+                             (RecordP (l' ': lin) (v' ': vin)) rout where     h2projectByLabels' _ ls (RecordP (HCons v' vs')) =         (RecordP (HCons v' vin), rout)         where (RecordP vin,rout) =                   h2projectByLabels ls ((RecordP vs')::RecordP ls' vs')  instance H2ProjectByLabels ls (RecordP ls' vs') rin (RecordP lo vo) =>-    H2ProjectByLabels' HFalse ls (RecordP (HCons l' ls') (HCons v' vs'))-                              rin (RecordP (HCons l' lo) (HCons v' vo)) where+    H2ProjectByLabels' False ls (RecordP (l' ': ls') (v' ': vs'))+                              rin (RecordP (l' ': lo) (v' ': vo)) where     h2projectByLabels' _ ls (RecordP (HCons v' vs')) =         (rin, RecordP (HCons v' vo))         where (rin,RecordP vo) =                   h2projectByLabels ls ((RecordP vs')::RecordP ls' vs')-+-} +{- -- -------------------------------------------------------------------------- -- Subtyping for records
HList.cabal view
@@ -1,12 +1,27 @@ Name:                HList-Version:             0.3.4.1+Version:             0.5.4.0 Category:            Data Synopsis:            Heterogeneous lists-Description:         HList is a record system providing strongly typed heterogenous lists, records,-                     type-indexed products (TIP) and co-products; licensed under the MIT X License.-                     .+Description:         HList provides many operations to create and manipulate+                     heterogenous lists (HLists) whose length and element+                     types are known at compile-time. HLists are used to implement+                    .+                      * records+                    .+                      * variants+                    .+                      * type-indexed products (TIP)+                    .+                      * type-indexed co-products (TIC)+                    .+                      * keyword arguments+                    .                      User code should import "Data.HList" or                      "Data.HList.CommonMain" for a slightly more limited scope+                    .+                     The original design is described in <http://okmij.org/ftp/Haskell/HList-ext.pdf>,+                     though since that paper came out, the -XTypeFamiles extension has been used to+                     replace `TypeCast` with `~`. License:             MIT License-File:        LICENSE Author:              2004 Oleg Kiselyov (FNMOC, Monterey), Ralf Laemmel (CWI/VU, Amsterdam),@@ -15,88 +30,191 @@  Data-files:          README, ChangeLog Cabal-version:       >= 1.10-Tested-With:         GHC==7.6.2, GHC==7.7+Tested-With:         GHC==9.4.8, GHC==9.6.6, GHC==9.8.2, GHC==9.10.1 Build-Type:          Simple  Extra-Source-Files:-                     examples/*.hs,                      examples/broken/*.hs,                      examples/broken/*.lhs,--                     examples/*.ref,-                     examples/*.out,-                      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+  Default: False+  Manual: True+  Description: use Data.Type.Equality.== to define the instance of HEq+               instead of overlapping instances (in Data.HList.TypeEqO)+               (needs ghc >= 7.8)+              .+               This version does not allow `HEq x [x] f` to lead to+               f ~ False, unlike the version with overlapping instances.+               See <https://ghc.haskell.org/trac/ghc/ticket/9918>+ library-  Build-Depends:       base >= 4 && < 5, template-haskell, ghc-prim, mtl,-                       tagged+  Build-Depends:       base >= 4.6 && < 4.21,+                       -- for Typeable '[] and '(:) with ghc-7.6+                       base-orphans,+                       -- Data.Semigroup for ghc < 8+                       semigroups,+                       template-haskell,+                       ghc-prim,+                       mtl,+                       tagged,+                       profunctors,+                       array +   Exposed-modules:     Data.HList,                        Data.HList.CommonMain,                        Data.HList.Data,+                       Data.HList.Dredge,                        Data.HList.FakePrelude,                        Data.HList.HArray,+                       Data.HList.HCurry,                        Data.HList.HList,                        Data.HList.HListPrelude,                        Data.HList.HOccurs,                        Data.HList.HTypeIndexed,+                       Data.HList.HSort,                        Data.HList.HZip,                        Data.HList.Keyword,                        Data.HList.Label3,+                       Data.HList.Label5,                        Data.HList.Label6,                        Data.HList.Labelable,                        Data.HList.MakeLabels,                        Data.HList.Record,                        Data.HList.RecordPuns,+                       Data.HList.RecordU,                        Data.HList.TIC,                        Data.HList.TIP,+                       Data.HList.TIPtuple,                        Data.HList.TypeEqO,                        Data.HList.Variant+  Other-modules:       LensDefs   Default-Language:    Haskell2010  -  Ghc-Options:         -Wall -fno-warn-missing-signatures+  Ghc-Options:         -Wall -fno-warn-missing-signatures -fno-warn-orphans    Default-Extensions:  ConstraintKinds                        DataKinds+                       DeriveDataTypeable                        EmptyDataDecls                        FlexibleContexts                        FlexibleInstances                        FunctionalDependencies+                       GeneralizedNewtypeDeriving                        GADTs                        KindSignatures                        MultiParamTypeClasses                        PolyKinds-                       RankNTypes,+                       RankNTypes                        ScopedTypeVariables+                       StandaloneDeriving                        TypeFamilies                        TypeOperators                        UndecidableInstances+  Other-Extensions:    CPP+                       TemplateHaskell+                       OverlappingInstances+  if impl(ghc >= 8.6)+    Default-Extensions: StarIsType +  if impl(ghc >= 8.0)+    Default-Extensions: UndecidableSuperClasses++  if impl(ghc < 7.7)+    Cpp-options:       -DOLD_TYPEABLE -DNO_CLOSED_TF+   if impl(ghc >= 7.7)     Default-Extensions: AllowAmbiguousTypes-                        StandaloneDeriving+                        RoleAnnotations +  if impl(ghc > 7.9)+    Ghc-Options:      -fno-warn-unticked-promoted-constructors+                      -Wno-star-is-type++  if flag(new_type_eq)+    Cpp-options:       -DNEW_TYPE_EQ+    Build-Depends:     base >= 4.7 && < 4.21+ Test-Suite examples   Type:     exitcode-stdio-1.0-  Ghc-Options: -threaded-  Main-Is: examples/runexamples.hs+  Main-Is: HListExample.hs   Default-Language:    Haskell2010-  Build-Depends:       base, hspec >= 1.7, directory, filepath,-                       process, syb, cmdargs, lens, HList, mtl+  Hs-Source-Dirs:  examples+  Build-Depends:       base < 4.21, hspec >= 1.7, directory, filepath,+                       hspec-expectations,+                       process,+                       syb,+                       cmdargs,+                       lens,+                       HList,+                       mtl,+                       QuickCheck,+                       array,+                       semigroups,+                       template-haskell+  Other-Modules:+        Properties.Common +        HListExample.CmdArgs+        HListExample.Datatypes2+        HListExample.Labelable+        HListExample.MainGhcGeneric1+        HListExample.MainPosting051106+        HListExample.OverloadedLabels+        HListExample.Prism+        HListExample.Pun+        HListExample.TIPTransform+        HListExample.TIPTransformM++  if impl(ghc > 7.9)+    Ghc-Options: -fno-warn-tabs+ Test-Suite doctests   Type:     exitcode-stdio-1.0   Ghc-Options: -threaded-  Main-Is: examples/rundoctests.hs-  Build-Depends: base, doctest >= 0.8, process+  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) => ...+    Build-Depends: base < 4.21, doctest >= 0.8, process+  Buildable: False+  Main-Is: rundoctests.hs+  Hs-Source-Dirs:  examples   Default-Language:    Haskell2010+++Test-Suite properties+  Type:     exitcode-stdio-1.0+  Build-Depends: base < 4.21,+                 hspec >= 1.7,+                 hspec-expectations,+                 HList,+                 lens,+                 mtl,+                 QuickCheck,+                 template-haskell,+                 array,+                 syb+  Other-Modules:+        Properties.Common+        Properties.KW+        Properties.LengthDependent+        Properties.LengthDependentSplice+        Properties.LengthIndependent+  Main-Is:  Properties.hs+  Hs-Source-Dirs: examples+  Default-Language:    Haskell2010+  if impl(ghc <= 7.11)+        build-depends: semigroups
+ LensDefs.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+-- | parts of lens that would be imported if we depended on it+module LensDefs+  (module LensDefs,+   module Control.Applicative,+   Choice,+   Profunctor,+   Coercible)+   where++import Data.Profunctor+import Data.Profunctor.Unsafe+import Control.Applicative+import Control.Monad.Identity++import Unsafe.Coerce+#if __GLASGOW_HASKELL__ > 707+import GHC.Exts(Coercible)+#else+import GHC.Exts(Constraint)+-- | for ghc-7.6 we don't have coercible+type Coercible a b = (() :: Constraint)+#endif+++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 &+x & f = f x++infixr 4 %~+l %~ f = \t -> runIdentity $ l (rmap Identity f) t++iso :: (Profunctor p, Functor f)+    => (s -> a) -> (b -> t)+    -> p a (f b) -> p s (f t)+iso sa bt = dimap sa (fmap bt)++-- | iso, except assumes that the functions supplied could+-- be 'Data.Coerce.coerce'+isoNewtype :: (Profunctor p, Functor f,+               Coercible b t, -- Coercible (f b) (f t) -- is really needed but that complicates types later on (since f is forall'd)+               Coercible a s)+    => (s -> a) -> (b -> t)+    -> p a (f b) -> p s (f t)+isoNewtype sa _bt x = coerceBT x .# sa+  where coerceBT :: p a (f b) -> p a (f t)+        coerceBT = unsafeCoerce++prism :: (b -> t) -> (s -> Either t a)+    -> (forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t))+prism bt seta = dimap seta (either pure (fmap bt)) . right'++prism' :: (a -> s) -> (s -> Maybe a)+    -> (forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s))+prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))
README view
@@ -2,7 +2,7 @@  Contributors: 	Justin Bailey, Brian Bloniarz, Gwern Branwen, Einar Karttunen,-	and Adam Vogt+	Daniil Iaitskov and Adam Vogt   The HList library and samples@@ -11,18 +11,19 @@  Getting the code -> darcs get http://code.haskell.org/HList+> git clone https://bitbucket.org/HList/hlist HList  ----------------------------------------------------------------------  Pushing changes -You need an account at code.haskell.org+You need an account at bitbucket.org  > cd HList-> darcs pull user@code.haskell.org:/srv/darcs/HList-> darcs record-> darcs push+> git clone git@bitbucket.org:HList/hlist.git+> git pull+> git commit --interactive+> git push  ---------------------------------------------------------------------- @@ -35,19 +36,35 @@ since doing so would have implied inclusion of substantial packages, namely the underlying infrastructure for database access library. -You can get HList from Hackage or from Darcs:+You can get HList from Hackage or from bitbucket:  $ cabal update && cabal install HList  Or: -$ darcs get --partial http://code.haskell.org/HList/+$ git clone https://bitbucket.org/HList/hlist HList $ cd HList; cabal install -The code works --- within the limits exercised in the source files ----for GHC-7.6 and GHC-7.7. Older compilers are not supported.+The code was tested --- within the limits exercised in the source files ---+with GHC 9.4.8 through 9.10.1 and it may still work older versions possibly back to+GHC-7.6 +Older compilers are not supported.+ One may run "cabal test" to check the distribution. -See ChangeLog for updates.+---------------------------------------------------------------------- +The library can be built and tested in the checked environment (with+compatible GHC, cabal and dependencies) provided by nix:++$ nix-build        # builds and runs tests+$ nix-shell --pure # drops into an isolated shell++nix usually can be installed with a single line:++$ sh <(curl -L https://nixos.org/nix/install) --no-daemon++----------------------------------------------------------------------++See ChangeLog for updates.
− Setup.hs 
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
− examples/Datatypes1.hs 
@@ -1,14 +0,0 @@-module Datatypes1 where---- The fout-n-mouth example--newtype Key     = Key Integer-                deriving (Show,Eq,Ord)-newtype Name   = Name String-                deriving (Show,Eq)-data Breed     = Cow | Sheep-                deriving (Show,Eq)-newtype Price  = Price Float-                deriving (Show,Eq,Ord)-data Disease   = BSE | FM-                deriving (Show,Eq)
− examples/Datatypes2.hs 
@@ -1,19 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Datatypes2 where--import Data.Typeable---- The fout-n-mouth example--- (deriving Typeable only supported for GHC)--newtype Key     = Key Integer-                deriving (Show,Eq,Ord,Typeable)-newtype Name   = Name String-                deriving (Show,Eq,Typeable)-data Breed     = Cow | Sheep-                deriving (Show,Eq,Typeable)-newtype Price  = Price Float-                deriving (Show,Eq,Ord,Typeable)-data Disease   = BSE | FM-                deriving (Show,Eq,Typeable)
− examples/FooBar.hs 
@@ -1,27 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-{-# OPTIONS -fallow-undecidable-instances #-}-{-# OPTIONS -fallow-overlapping-instances #-}--data Foo x y-class Bar x y | x -> y-class Zoo x y | x -> y--{---Works for both GHC and Hugs--instance Bar (Foo x y) y-instance Bar (Foo (Foo x y) z) z---}--{---Works for GHC but not Hugs---}--instance Zoo x r => Bar (Foo x y) r-instance Zoo x r => Bar (Foo (Foo x y) z) r--
+ examples/HListExample.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- tests based on HListExample+module Main (main) where+++import Test.Hspec+++import HListExample.Labelable+import HListExample.CmdArgs+import HListExample.MainGhcGeneric1+-- import HListExample.MainPosting040607+import HListExample.MainPosting051106+import HListExample.Prism+import HListExample.Pun+import HListExample.TIPTransform+import HListExample.TIPTransformM+import HListExample.OverloadedLabels+++main = hspec $ do+  mainCmdargs+  mainLabelable+  mainGhcGeneric1+  mainPosting051106+  mainPrism+  mainPun+  mainTIPTransform+  mainTTIPM+  mainOverloadedLabels++++++
+ examples/HListExample/CmdArgs.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}+module HListExample.CmdArgs where+++import Data.Generics+import Control.Lens+import Test.Hspec+import Properties.Common++import Data.HList.CommonMain++import System.Console.CmdArgs (cmdArgs)+import System.Environment (withArgs)+++{-++An example showing off the data instance for Record / Variant / TIP / TIC++Also a use of cmdArgs++Note that ghc-7.8.2 does not have (or can produce) instances of typeable+for types of kind Symbol (ie. promoted strings):+<https://ghc.haskell.org/trac/ghc/ticket/9111>, so for now use the Label3+style++-}++#define USE_LABEL3 __GLASGOW_HASKELL__ == 708++#if USE_LABEL3+makeLabels3 "examples_cmdargs" (words "x y z tic")+makeLabels3 "optV" (words "optA optB optC")+#else+makeLabels6 (words "x y z tic")+makeLabels6 (words "optA optB optC")+#endif++makeLabelable "abc df"++#if USE_LABEL3+v = (optA .*. optB .*. optC .*. emptyProxy)+      `zipTagged` (Proxy :: Proxy '[Int,Char,Double])+#else+v = Proxy :: Proxy '[Tagged "optA" Int, Tagged "optB" Char, Tagged "optC" Double]+#endif++type Z' = TagR [Int, Char, Double]+-- type Z' = [Tagged Int Int, Tagged Char Char, Tagged Double Double]++d0 = x .=. (5 :: Int)+    .*. y .=. True+    .*. z .=. mkVariant optC (1 :: Double) v+    .*. tic .=. mkTIC' 'x' (Proxy :: Proxy Z')+    .*. emptyRecord++-- the equivalent ordinary record for reference+data E = E { a :: Int, b :: Bool }+    deriving (Show, Data, Typeable)++data Opt = OptA Int | OptB Char | OptC Double+    deriving (Show, Data, Typeable)++e0 = E 5 True++mainCmdargs = describe "cmdargs/Data" $ do+  it "variant show" $+    mkVariant optC 1 v `shouldShowTo` "V{optC=1.0}"++  -- increment V{optC=1.0} via data instance+  it "gmapT" $+    gmapT (mkT ((+1) :: Double -> Double)) (mkVariant optC 1 v)+     `shouldShowTo` "V{optC=2.0}"++  it "d0" $+    d0 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Bool children" $+    gmapT (mkT not) d0 `shouldShowTo`+      "Record{x=5,y=False,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Int children" $+    gmapT (mkT (+(1::Int))) d0 `shouldShowTo`+      "Record{x=6,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Char children (none)" $+    gmapT (mkT (succ :: Char -> Char)) d0 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Char grandchildren" $+    everywhere (mkT (succ :: Char -> Char)) d0 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='y'}}"++#if __GLASGOW_HASKELL__ != 706+  --  ghc-7.6.3 fails with all uses of dredge:+  --     Kind incompatibility when matching types:+  --    Const (Data.Monoid.First Double) Double :: AnyK+  --    Const (Data.Monoid.First Double) Double :: *++  it "dredge optC" $+    d0 & dredge optC +~ 1 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=2.0},tic=TIC{char='x'}}"+#endif++  -- theB is like a TIP the unsafe lookup function applied+  let theB :: Typeable a => a+      theB = error "theB"+            `extB` (1::Int)+            `extB` True+            `extB` (2.5::Double)+            `extB` 'b'+            `extB` mkVariant optC theB v+            `extB` mkTIC' (theB :: Char) (Proxy :: Proxy Z')++  it "fromConstrB" $+    fromConstrB theB undefined `asTypeOf` d0 `shouldShowTo`+      "Record{x=1,y=True,z=V{optC=2.5},tic=TIC{char='b'}}"++  it "cmdargs built-in data" $+    withArgs ["-a=4", "-b=False" ] (cmdArgs e0) `shouldReturnShowTo`+        "E {a = 4, b = False}"++  -- drop the tic and variant-containing fields: cmdargs doesn't support+  -- it. Cmdargs doesn't support fields containing+  -- `data Opt = OptA Int | OptB Char` either+  let dRec = d0 & from hListRecord %~ (hInit . hInit)++  it "dRec" $+    dRec `shouldShowTo`+      "Record{x=5,y=True}"++  it "cmdargs Record" $+    withArgs ["-x=4", "-y=False"] (cmdArgs dRec) `shouldReturnShowTo`+      "Record{x=4,y=False}"+
+ examples/HListExample/Datatypes2.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}++module HListExample.Datatypes2 where++import Data.Typeable++-- The fout-n-mouth example+-- (deriving Typeable only supported for GHC)++newtype Key     = Key Integer+                deriving (Show,Eq,Ord,Typeable)+newtype Name   = Name String+                deriving (Show,Eq,Typeable)+data Breed     = Cow | Sheep+                deriving (Show,Eq,Typeable)+newtype Price  = Price Float+                deriving (Show,Eq,Ord,Typeable)+data Disease   = BSE | FM+                deriving (Show,Eq,Typeable)
+ examples/HListExample/Labelable.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds,+  GADTs, ConstraintKinds #-}+{- | Demonstrates @hLens'@++may be worthwhile to have a lens-free test suite, doing stuff like:++> case x (Identity  . (++"there")) r of Identity t -> t++-}+module HListExample.Labelable where+import Data.HList.CommonMain+import Control.Lens++import Text.Read++import Properties.Common+import Test.Hspec+++makeLabelable "lbX lbY"++#if __GLASGOW_HASKELL__ < 707+#define INT_SIG_76 :: Int+#else+#define INT_SIG_76+#endif++r = lbX .==. "hi" .*.+    lbY .==. (lbY .==. 321 .*. lbX .==. 123 .*. emptyRecord) .*.+    emptyRecord++mainLabelable = describe "labelable" $ do+  it "lookup" $ do+    r ^. lbX      `shouldShowTo` "\"hi\""++    -- ghc-7.6 doesn't default when r is involved lower down,+    -- while 7.8.2 does+    (r ^. lbY . lbY  INT_SIG_76) `shouldShowTo` "321"+    (r ^. lbY . lbX  INT_SIG_76) `shouldShowTo` "123"++  it "modify" $ do+    r & lbX .~ () `shouldShowTo`+        "Record{lbX=(),lbY=Record{lbY=321,lbX=123}}"++    r & lbY . lbY .~ "xy" `shouldShowTo`+        "Record{lbX=\"hi\",lbY=Record{lbY=\"xy\",lbX=123}}"++  it "read/show" $ do+    let rString = "Record{lbX=\"hi\",lbY=Record{lbY=321,lbX=123}}"++    r `shouldShowTo` rString++    readMaybe rString `asTypeOf` Just r+        `shouldBe` Just r++    -- the read instance does not reorder labels+    let rStringPerm = "Record{lbY=Record{lbY=321,lbX=123},lbX=\"hi\"}"+    readMaybe rStringPerm `asTypeOf` Just r+        `shouldBe` Nothing++    -- but we can reorder this way+    (r ^. rearranged) `asTypeOf` (undefined :: Record '[Tagged "lbY" t, Tagged "lbX" s])+        `shouldShowTo` rStringPerm
+ examples/HListExample/MainGhcGeneric1.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{-++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   This is a main module for exercising a model with generic type+   cast and generic type equality.++-}++module HListExample.MainGhcGeneric1 (mainGhcGeneric1) where++import HListExample.Datatypes2+import Data.HList.CommonMain+import Control.Lens++import Properties.Common+import Test.Hspec++import Control.Monad.Writer++-- --------------------------------------------------------------------------++type Animal =  '[Key,Name,Breed,Price]++angus :: HList Animal+angus =  HCons (Key 42)+           (HCons (Name "Angus")+           (HCons  Cow+           (HCons (Price 75.5)+            HNil)))++tlist1 = hFoldr (HSeq HPrint) (return () :: IO ()) angus++testBasic = do+  it "basic" $ do+    -- tlist1 does IO. The equivalent using Writer+    let f = HSeq $ HComp (tell . (:[])) HShow+        f2 = Fun (tell . (:[]) . show) :: Fun Show (Writer [String] ())++        angusStr = ["Key 42",  "Name \"Angus\"", "Cow", "Price 75.5" ]++    execWriter (hFoldr f (return ()) angus) `shouldBe`+        angusStr++    execWriter (hFoldr (HSeq f2) (return ()) angus) `shouldBe`+        angusStr+++    hAppend angus angus `shouldShowTo` +      "H[Key 42,Name \"Angus\",Cow,Price 75.5,Key 42,Name \"Angus\",Cow,Price 75.5]"+++testHArray = do+  it "HArray" $ do+    hProjectByHNats (hNats (HCons hZero (HCons hZero HNil))) angus `shouldShowTo`+      "H[Key 42]"++      -- Before:+      -- H[Key 42, Key 42]+      -- XXX I don't duplicate at present!+    hProjectByHNats (hNats (HCons hZero (HCons (hSucc hZero) HNil))) angus `shouldShowTo`+      "H[Key 42,Name \"Angus\"]"++    hProjectByHNats (undefined::Proxy ['HZero, 'HSucc 'HZero]) angus `shouldShowTo`+      "H[Key 42,Name \"Angus\"]"++    hProjectAwayByHNats (hNats (HCons hZero HNil)) angus `shouldShowTo`+      "H[Name \"Angus\",Cow,Price 75.5]"++    hSplitByHNats +	    (undefined::Proxy ['HZero, 'HSucc 'HZero])+	    angus+      `shouldShowTo`+      "(H[Key 42,Name \"Angus\"],H[Cow,Price 75.5])"+++  it "HOccurs" $ do+    (hOccurs angus :: Breed) `shouldShowTo` "Cow"+    hOccurs angus `shouldBe` Cow++    hOccurs (hBuild 1 ^. from tipHList) `shouldShowTo` "1"++    (null $ hOccurs $ hBuild [] ^. from tipHList) `shouldBe` True+    (hProject angus :: HList '[Key, Name]) `shouldShowTo`+      "H[Key 42,Name \"Angus\"]"+++  it "TypeIndexed" $ do+    let typeIdx1 = hDeleteMany (undefined::Proxy Name) angus+        typeIdx2 = BSE .*. angus+    typeIdx1 `shouldShowTo` "H[Key 42,Cow,Price 75.5]"+    typeIdx2 `shouldShowTo` "H[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]"++    hUpdateAt Sheep typeIdx1 `shouldShowTo`+      "H[Key 42,Sheep,Price 75.5]"+  +    hDeleteAt (undefined::Proxy Breed) typeIdx2 `shouldShowTo`+      "H[BSE,Key 42,Name \"Angus\",Price 75.5]"++    hProjectBy (undefined::Proxy '[Breed]) angus `shouldShowTo` "H[Cow]"++    hProject angus `shouldBe` HCons Cow HNil++    -- doesn't work+    -- hProjectBy Proxy angus `shouldBe` HCons Cow HNil++    hSplitBy (undefined:: Proxy '[Breed]) angus `shouldShowTo`+      "(H[Cow],H[Key 42,Name \"Angus\",Price 75.5])"++testTIP = do+  -- |+  -- This example from the TIR paper challenges singleton lists.+  -- Thanks to the HW 2004 reviewer who pointed out the value of this example.+  -- We note that the explicit type below is richer than the inferred type.+  -- This richer type was needed for making this operation more polymorphic.+  -- That is, /a)/ would not work without the explicit type, +  -- while /b/ would:+  --+  -- >  a)  ((+) (1::Int)) $ snd $ tuple oneTrue+  -- >  b)  ((+) (1::Int)) $ fst $ tuple oneTrue+  --+  -- As of 2014, type signatures are not needed to define tipyTuple.+  it "tipyTuple" $ do+    let tuple l = tipyTuple l++        -- oneTrue :: TIP (TagR [Int, Bool])		-- inferred+        -- oneTrue :: TIP '[Tagged Int Int, Tagged Bool Bool] -- expanded out+        oneTrue = (1::Int) .*. True .*. emptyTIP++    case tuple oneTrue of+      (a,b) -> (a+(1::Int), not b) `shouldShowTo` "(2,False)"++    not (fst (tuple oneTrue)) `shouldShowTo` "False"+    tuple oneTrue `shouldBe` (1::Int,True)++    (((+) (1::Int)) $ fst $ tuple oneTrue) `shouldBe` 2+    (((+) (1::Int)) $ snd $ tuple oneTrue) `shouldBe` 2+++  it "tip" $ do+    hOccurs myTipyCow `shouldBe` Cow+    (BSE .*. myTipyCow) `shouldShowTo` "TIPH[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]"+    -- (Sheep .*. myTipyCow) `shouldBe`  _+    {- if we uncomment the line above, we get the type error+       about the violation of the TIP condition: Breed type+       occurs twice.++      No instance for (Fail * (TypeFound Breed))+    -}++    (Sheep .*. hDeleteAtLabel (Label :: Label Breed) myTipyCow)+        `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]"++    (Sheep .*. (myTipyCow .-. (Label :: Label Breed)))+        `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]"++    tipyUpdate Sheep myTipyCow+        `shouldShowTo` "TIPH[Key 42,Name \"Angus\",Sheep,Price 75.5]"+++++myTipyCow = tipHList # angus -- lens #++animalKey :: ( SubType l (TIP Animal) -- explicit+             , HOccurs Key l          -- implicit+             ) => l -> Key+animalKey = hOccurs++animalish :: SubType l (TIP Animal) => l -> l+animalish = id+animalKey' l = hOccurs (animalish l) :: Key+++makeLabels3 "MyNS" (words "key name breed price")+{- ^ makeLabels3 generates something like+data MyNS = MyNS -- a name space for record labels++key   = firstLabel MyNS  (undefined::DKey)+name  = nextLabel  key   (undefined::DName)+breed = nextLabel  name  (undefined::DBreed)+price = nextLabel  breed (undefined::DPrice)++data DKey;   instance Show DKey   where show _ = "key"+data DName;  instance Show DName  where show _ = "name"+data DBreed; instance Show DBreed where show _ = "breed"+data DPrice; instance Show DPrice where show _ = "price"++-}++unpricedAngus =  key    .=. (42::Integer)+             .*. name   .=. "Angus"+             .*. breed  .=. Cow+             .*. emptyRecord+++testRecords = describe "testRecords" $ it "tests" $ do++  unpricedAngus `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Cow}"+  unpricedAngus .!. breed `shouldShowTo` "Cow"++  let test3 = hDeleteAtLabel breed unpricedAngus++  test3+    `shouldShowTo` "Record{key=42,name=\"Angus\"}"++  (breed .=. Sheep .@. unpricedAngus)+    `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Sheep}"++  let test4 = price .=. 8.8 .*. unpricedAngus++  test4+    `shouldShowTo` "Record{price=8.8,key=42,name=\"Angus\",breed=Cow}"++  hProjectByLabels (labelsOf (breed `HCons` price `HCons` HNil)) test4+    `shouldShowTo` "Record{price=8.8,breed=Cow}"++  -- XXX extra Label shouldn't be needed?+  -- alternatively it could be a compile-time error...+  -- hProjectByLabels (hEndP $ hBuild breed price) test4+  --  `shouldShowTo` "Record{price=8.8,breed=Cow}"++  -- test7 should be the same as test4 but+  -- with the different order of labels+  (newLVPair breed Sheep) .*. test3+    `shouldShowTo` "Record{breed=Sheep,key=42,name=\"Angus\"}"+++type AnimalCol = TagR [Key,Name,Breed,Price]+++testTIC = describe "TIC" $ do+  it "show" $+    (myCol :: TIC AnimalCol) `shouldShowTo` "TIC{breed=Cow}"+  it "hOccurs found" $+    (hOccurs myCol :: Maybe Breed) `shouldBe` Just Cow+  it "hOccurs absent" $+    (hOccurs myCol :: Maybe Price) `shouldBe` Nothing++myCol = mkTIC Cow :: TIC AnimalCol+{-++*TIC> mkTIC "42" :: TIC AnimalCol+Type error ...++*TIC> hOccurs myCol :: Maybe String+Type error ...++-- both of the these type errors could be better+-- (on ghc-7.10.3), Any is used to satisfy FD coverage condition, but the+-- TypeError context should be printed instead+<interactive>:170:1:+    Couldn't match type ‘Data.HList.CommonMain.Any’ with ‘[Char]’+    In the expression: mkTIC "42" :: TIC AnimalCol+    In an equation for ‘it’: it = mkTIC "42" :: TIC AnimalCol+-}++testVariant = describe "Variant" $ it "test" $ do+    testVar1 `shouldShowTo` "V{name=\"angus\"}"+    (testVar1 .!. key) `shouldBe` Nothing+    (testVar1 .!. name) `shouldBe` Just "angus"+ where+  testVar1 = mkVariant name "angus" animalVar++animalVar = asProxy $+               key   .=. (undefined :: Integer)+           .*. name  .=. (undefined :: String)+           .*. breed .=. (undefined :: Breed)+           .*. emptyRecord+++asProxy :: proxy a -> Proxy a+asProxy _ = Proxy++mainGhcGeneric1 = describe "mainGhcGeneric1" $ do+  testBasic+  testHArray+  testTIP+  testRecords+  testTIC+  testVariant
+ examples/HListExample/MainPosting051106.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# LANGUAGE TypeOperators #-}+#endif+module HListExample.MainPosting051106 where++-- Needed for a reply to the Haskell mailing list++import Data.HList.CommonMain hiding (Comp(..))+import Properties.Common+import Test.Hspec++mainPosting051106 = describe "hComposeList (a -> H[a -> b,b -> c,c -> d] -> d)" $ do+    it "defined here" $+        comp "abc" `shouldShowTo` "8"++    it "defined in HList" $+        hComposeList test2 "abc" `shouldShowTo` "8"++test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil))+test2 = length .*. (+1) .*. (*2) .*. HNil++data Comp++{- simpler class. wouldn't work with test2. The original HFoldr won't work with+ - Apply anymore.+instance Apply Comp (x -> y,y -> z)+ where+  type ApplyR Comp (x -> y,y -> z) = x -> z+  apply _ (f,g) = g . f+  -}++-- `~` is (built-in) TypeCast mentioned below+instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz)+    => ApplyAB Comp xyz xz+ where+  applyAB _ (f,g) = g . f++-- Function composition based on type code works.++comp  = hFoldr (undefined::Comp) (id::Int -> Int) test++-- Function composition based on normal polymorphism doesn't+-- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++{-++From Ralf.Lammel at microsoft.com  Mon Nov  7 00:11:01 2005+From: Ralf.Lammel at microsoft.com (Ralf Lammel)+Date: Sun Nov  6 23:50:27 2005+Subject: [Haskell-cafe] Type classes and hFoldr from HList+Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com>++Hi Greg,++Since hfoldr is right-associative, I prefer to reorder your list of+functions as follows:++> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons+((*2)::(Int->Int)) HNil))++Note that I also annotated length with its specific type.+(If you really wanted to leave things more polymorphic, you would need+to engage in TypeCast.)++Providing a specific Apply instance for (.) is not necessary, strictly+necessary. We could try to exploit the normal function instance for+Apply.++Let me recall that one here for convenience:++>instance Apply (x -> y) x y+> where+>  apply f x = f x++Let me also recall the hFoldr instances:++>class HList l => HFoldr f v l r | f v l -> r+> where+>  hFoldr :: f -> v -> l -> r++>instance HFoldr f v HNil v+> where+>  hFoldr _ v _ = v++>instance ( HFoldr f v l r+>         , Apply f (e,r) r'+>         )+>      => HFoldr f v (HCons e l) r'+> where+>  hFoldr f v (HCons e l) = apply f (e,hFoldr f v l)+++To fit in (.), we would flip and uncurry it.+So we could try:++comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++This wouldn't work.+The trouble is the required polymorphism of the first argument of+hFoldr.+The type of that argument as such is polymorphic.+However, this polymorphism does not survive type class parameterization.+You see this by looking at the HCons instance of HFoldr.+The different occurrences of "f" would need to be used at different+types.+This would only work if the type class parameter f were instantiated by+the polymorphic type of (uncurry (flip (.))). (And even then we may need+something like TypeCast.)++What you can do is define a dedicated *type code* for composition.++comp  = hFoldr (undefined::Comp) (id::Int -> Int) test++data Comp++instance Apply Comp (x -> y,y -> z) (x -> z)+ where+  apply _ (f,g) = g . f+++Ralf+++> -----Original Message-----+> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe-+> bounces@haskell.org] On Behalf Of Greg Buchholz+> Sent: Sunday, November 06, 2005 7:01 PM+> To: haskell-cafe@haskell.org+> Subject: [Haskell-cafe] Type classes and hFoldr from HList+>+>+>   I was playing around with the HList library from the paper...+>+>     Strongly typed heterogeneous collections+>     http://homepages.cwi.nl/~ralf/HList/+>+> ...and I thought I'd try to fold the composition function (.) through+a+> heterogeneous list of functions, using hFoldr...+>+> >{-# OPTIONS -fglasgow-exts #-}+> >{-# OPTIONS -fallow-undecidable-instances #-}+> >+> >import CommonMain+> >+> >main = print $ comp "abc"+> >+> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons+length+> HNil))+> >+> >comp = hFoldr (.) id test+> >+> >instance Apply (a -> b -> c -> d) (a, b) (c -> d)+> >    where+> >        apply f (a,b) = f a b+>+> ...but it fails with the following type error...+>+> ]Compiling Main             ( compose.hs, interpreted )+> ]+> ]compose.hs:10:7:+> ]    No instances for (Apply ((b -> c) -> (a -> b) -> a -> c)+> ]                            (Int -> Int, r)+> ]                            ([Char] -> a3),+> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) (Int ->+Int,+> r1) r,+> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] ->+> Int, a1 ->a1) r1)+> ]      arising from use of `hFoldr' at compose.hs:10:7-12+> ]    Probable fix:+> ]      add an instance declaration for (Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ]                                             (Int -> Int, r)+> ]                                             ([Char] -> a3),+> ]                                       Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ](Int -> Int, r1) r,+> ]                                       Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ]([a2] -> Int, a1 -> a1) r1)+> ]    In the definition of `comp': comp = hFoldr (.) id test+>+> ...Anyway, I couldn't quite tell whether I was using hFoldr+incorrectly,+> or if I needed to have more constraints placed on the construction of+> "test", or if needed some sort of type-level function that resolves...+>+> Apply ((b -> c) -> (a -> b) -> a -> c)+>+> ...into (a -> c), or something else altogether.  I figured someone+might+> be able to help point me in the right direction.++-}
+ examples/HListExample/OverloadedLabels.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedLabels, TypeOperators, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes, PolyKinds, TypeApplications, DataKinds #-}+module HListExample.OverloadedLabels where++import Data.HList.CommonMain+import GHC.OverloadedLabels+import Control.Lens+import Data.HList.Labelable+import Properties.Common+import Test.Hspec+import GHC.TypeLits++{- | -XOverloadedLabels expands #foo into `hLens' (Label :: Label "foo")`+++Not in Data.HList.Labelable because it would overlap other uses of IsLabel+-}+instance (Labelable x r s t a b, x ~ x_,+    lens ~ ((a `p` f b) `to` (r s `p` f (r t))),+    ty ~ LabelableTy r,+    LabeledOpticF ty f,+    LabeledOpticP ty p,+    LabeledOpticTo ty x to +    ) => IsLabel x_ lens where+   fromLabel = hLens' (Label :: Label x)+++{- | hLens' where the `x` type parameter must be supplied by -XTypeApplications.+In other words these are all equivalent:++> hLens' (Label :: Label "abc")+> hLens' (Label @"abc")+> hL @"abc"+> `abc -- HListPP+ +-}+hL :: forall x r s t a b to p f.+     Labelable x r s t a b =>+     LabeledOptic x r s t a b +hL = hLens' (Label :: Label x)+++r = #abc .==. 3 .*. emptyRecord+++mainOverloadedLabels = describe "-XOverloadedLabels" $ do+ it "lookup" $ do+    r ^. #abc `shouldShowTo` "3"+    r ^. hL @"abc" `shouldShowTo` "3"
+ examples/HListExample/Prism.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-} -- for pun+{-# LANGUAGE TemplateHaskell #-}+module HListExample.Prism where+++import Test.Hspec+import Properties.Common++import Data.HList.CommonMain+import Data.HList.Labelable (hLens')+import Control.Lens++-- generate left = Label :: Label "left"+makeLabels6 (words "left right up down")++--- define the Labelable labels manually+left_ = hLens' left+right_ = hLens' right+up_ = hLens' up+down_ = hLens' down++-- this definition is needed to decide what order+-- to put the fields in, as well as their initial types+r = [pun|right left up|] where+  left = 'a'+  right = 2 :: Int+  up = 2.3 :: Double++r2 = down_ .==. v .*. r++v = mkVariant left 'x' r++mainPrism = do+  it "inspect v with hPrism" $ do+    v ^? hPrism left `shouldShowTo` "Just 'x'"+    v ^? hPrism right `shouldBe` Nothing+    v ^? hPrism up `shouldBe` Nothing+    v2 ^? hPrism left `shouldShowTo` "Just ()"++  it "inspect v with hPrism through Labelable" $ do+    v ^? left_ `shouldShowTo` "Just 'x'"+    v ^? right_ `shouldBe` Nothing+    v ^? up_ `shouldBe` Nothing+    v2 ^? left_ `shouldShowTo` "Just ()"++  it "Setting the missing tag does nothing" $ do+    set right_ () v `shouldShowTo` "V{left='x'}"++    set _Right () (Left 'x') -- prisms for Either do the same thing+      `shouldShowTo` "Left 'x'"++  it "compose prism" $ do+    v3 ^? up_.up_ `shouldBe` Nothing+    v3 ^? left_ `shouldShowTo` "Just 'x'"++    v4 ^? left_.left_ `shouldShowTo` "Just \"leftleft\""++  it "compose lens.prism" $ do+    r2 ^? down_.left_ `shouldShowTo` "Just 'x'"+    r2 ^? down_.right_ `shouldBe` Nothing++    let du = down_.up_+    r2 ^? du `shouldBe` Nothing++  it "extension" $ do+    v5 ^? down_ `shouldBe` Just "hi"+    v6 ^? down_ `shouldBe` Just "hi"+    v7 ^? down_ `shouldBe` Nothing+    v7 ^? left_ `shouldBe` Just 'x'++  it "show" $ do+    vs `shouldShowTo`+        "Record{v=V{left='x'},\+        \v2=V{left=()},\+        \v2'=V{left=()},\+        \v3=V{left='x'},\+        \v4=V{left=V{left=\"leftleft\"}},\+        \v5=V{down=\"hi\"},\+        \v6=V{down=\"hi\"},\+        \v7=V{left='x'}}"++    -- works in ghci. Probably need -XExtendedDefaultRules+    -- wX `shouldShowTo` "V{x='a'}"+    -- wY `shouldShowTo` "V{y=2.5}"+    [wX,wY] `shouldShowTo` "[V{x='a'},V{y=2.5}]"++  -- :t wX+  -- > wX :: Variant '[Tagged "x" Char, Tagged "y" y]+  --+  -- > :t wY+  -- > wY :: Variant '[Tagged "x" x, Tagged "y" Double]+  --+  -- ghc doesn't need to decide on a type for values that+  -- have no influence on the final result+  it "type partly defined" $ do+    wX ^? hLens' (Label :: Label "x")+        `shouldShowTo` "Just 'a'"+    wY ^? hLens' (Label :: Label "y")+        `shouldShowTo` "Just 2.5"+  ++wX = mkVariant (Label :: Label "x") 'a' wProto+wY = mkVariant (Label :: Label "y") (2.5 :: Double) wProto++wProto = undefined :: Record+  '[Tagged "x" x, Tagged "y" y]++vs = [pun| v v2 v2' v3 v4 v5 v6 v7 |]++-- note that we can change the type of the 'x' field+-- from Char to ()+v2 = set (hPrism left) () v+++-- or with the "better" label+v2' = set left_ () v+++v3 = v & up_ .~ v & up_.up_ .~ "upup"+v4 = v & left_ .~ v & left_.left_ .~ "leftleft"+v5 = down .=. Just "hi" .*. v+v6 = down_ .==. Just "hi" .*. v+v7 = down .=. (Nothing :: Maybe String) .*. v
+ examples/HListExample/Pun.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+-- more examples for record puns+module HListExample.Pun where+import Data.HList.CommonMain++import Test.Hspec+import Properties.Common++makeLabels6 (words "a b c")+++r  = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord+r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord+++p1 ( (.!. b) -> (b@((.!. a) -> a))) = (a,b)++p2 [pun| b @ {a} |] = (a, b)++-- same as p2, but gives a warning+-- p3 [pun| b @ a |] = (a, b)++p4 [pun| b{a} |] = a -- b is not bound++-- adds `x' and `y' into a field called r+e1 = let x = 1; y = "hi" in [pun| r @ { x y } |]++-- updates the `c' field+e2 = let c = 1; y = "hi" in [pun| r @ { c y } |]++-- same as e1, but doesn't use a pre-existing r+e3 = let x = 1; y = "hi" in [pun| r { x y } |]+++mainPun = describe "pun quasiquoter" $ do+  it "pattern" $ do+        p1 r `shouldShowTo` "(3,Record{a=3})"+        p2 r `shouldShowTo` "(3,Record{a=3})"+        p4 r `shouldBe` 3++  it "expression" $ do+        e1 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\",c=\"c\",b=Record{a=3}}}"+        e2 `shouldShowTo` "Record{r=Record{c=1,y=\"hi\",b=Record{a=3}}}"+        e3 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\"}}"+
+ examples/HListExample/TIPTransform.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}++-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- +-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.++module HListExample.TIPTransform where++import Data.HList.CommonMain+import Data.Typeable++import Properties.Common+import Test.Hspec++-- We start with the examples++newtype MyVal = MyVal Int deriving (Show, Typeable)++-- or if no typeable, use+-- instance ShowLabel MyVal where showLabel _ = "MyVal"++tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP+++mainTIPTransform = describe "tipTransform" $ it "all" $ do+  tip1 `shouldShowTo` "TIPH[MyVal 20,1,True]"++  -- Update the Int component of tip1 to 2. The Int component must+  -- exist. Otherwise, it is a type error+  ttip (2::Int) tip1 `shouldShowTo`+        "TIPH[MyVal 20,2,True]"++  -- Negate the boolean component of tip1+  ttip not tip1 `shouldShowTo`+        "TIPH[MyVal 20,1,False]"++  -- Update the Int component from the values of two other components+  ttip (\(MyVal x) y -> x+y) tip1 `shouldShowTo`+    "TIPH[MyVal 20,21,True]"++  -- Update the MyVal component from the values of three other components+  ttip (\b (MyVal x) y -> MyVal $ if b then x+y else 0) tip1+        `shouldShowTo`+        "TIPH[MyVal 21,1,True]"++  -- The same but with the permuted argument order.+  -- The order of arguments is immaterial: the values will be looked up using+  -- their types+  ttip (\b y (MyVal x)-> MyVal $ if b then x+y else 0) tip1+        `shouldShowTo`+        "TIPH[MyVal 21,1,True]"++-- The implementation+-- part of HList proper now
+ examples/HListExample/TIPTransformM.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}  -- !TF+-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- The monadic version.+-- This file contains two versions of the code.+-- The comments -- !Simple and -- !TF distinguish the versions+--+-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.+-- In March 2010, Andrew Frank extended the problem for monadic operations.+-- This is the monadic version of TIPTransform.hs in the present directory.+++module HListExample.TIPTransformM where++import Data.HList.CommonMain+import Data.Typeable+import Control.Monad.Identity+import Control.Monad.Writer++import Test.Hspec+import Properties.Common++-- We start with the examples++newtype MyVal = MyVal Int deriving (Show,Typeable)++-- A specialized version of return for the Identity monad.+-- It is needed only for the Simple version of the code,+-- to tell the type checker the monad in which the computation is+-- taking place.+-- For the TF version of the code, we can use the ordinary return+-- in place of retI.+retI :: a -> Identity a+retI = return++-- A sample TIP+tip1 = MyVal 20 .*. (1::Int) .*. True .*. (3.5::Float) .*. emptyTIP+-- TIP (HCons (MyVal 20) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Update the Int component of tip1 to 2. The Int component must+-- exist. Otherwise, it is a type error+-- tip2 = runIdentity $ ttipM (retI (2::Int)) tip1 -- !Simple+tip2 = runIdentity $ ttipM (return (2::Int)) tip1  -- !TF+-- TIP (HCons (MyVal 20) (HCons 2 (HCons True (HCons 3.5 HNil))))+++-- Negate the boolean component of tip1+-- tip3 = runIdentity $ ttipM (retI . not) tip1 -- !Simple+tip3 = runIdentity $ ttipM (return . not) tip1      -- !TF+-- TIP (HCons (MyVal 20) (HCons 1 (HCons False (HCons 3.5 HNil))))++-- Update the Int component from the values of two other components+tip4 = runIdentity $ ttipM (\(MyVal x) y -> retI $ x+y) tip1+-- TIP (HCons (MyVal 20) (HCons 21 (HCons True (HCons 3.5 HNil))))++-- Update the MyVal component from the values of three other components+tip5 = runIdentity $ +       ttipM (\b (MyVal x) y -> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- The same but with the permuted argument order.+-- The order of arguments is immaterial: the values will be looked up using+-- their types+tip5' = runIdentity $ +        ttipM (\b y (MyVal x)-> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Andrew Frank's test+-- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil)))))+tip6 :: IO (TIP (TagR [MyVal,Int,Bool, Float]))+tip6 = ttipM op6 tip1++op6 :: MyVal -> Bool -> IO MyVal+op6 (MyVal x) b = do+                let m = if b then MyVal (x `div` 4) else MyVal (x * 4)+                putStrLn $ "MyVal is now " ++ show m+                            -- ==>> MyVal 5+                return m+-- TIP (HCons (MyVal 5) (HCons 1 (HCons True (HCons 3.5 HNil))))+++op6w :: MyVal -> Bool -> Writer String MyVal+op6w (MyVal x) b = do+                let m = if b then MyVal (x `div` 4) else MyVal (x * 4)+                tell ("MyVal is now " ++ show m)+                            -- ==>> MyVal 5+                return m+++{-  -- !Simple+-- The Simple implementation+-- The drawback is the need to let the type checker know the monad in which the+-- computations take place. That is why we had to use retI in the above+-- code, which is a specialized version of return for the Identity monad. +-- In op6, the presence of putStrLn unambiguously specified the monad, viz. IO,+-- so no special return are required.++class Monad m => TransTIPM m op db where+    ttipM :: op -> db -> m db++-- If the operation is the computation in the desired monad,+-- the type of the computation must match an element of TIP.+instance (Monad m,+	  HTypeIndexed db, HUpdateAtHNat n op db db, HType2HNat op db n)+    => TransTIPM  m (m op) (TIP db) where+    ttipM op db = do+                     op' <- op+		     return $ tipyUpdate op' db++-- If op is not a computation in the desired monad m, +-- it must be a function. Look up its argument in a TIP and recur.+instance (Monad m, HOccurs arg db, TransTIPM m op db)+    => TransTIPM m (arg -> op) db where+    ttipM f db = ttipM (f (hOccurs db)) db+-} -- !Simple++-- {- -- !TF+-- Moved to TIP.hs+-- -} -- !TF++mainTTIPM = describe "ttipM" $ it "all" $ do+  tip1 `shouldShowTo` "TIPH[MyVal 20,1,True,3.5]"+  tip2 `shouldShowTo` "TIPH[MyVal 20,2,True,3.5]"+  tip3 `shouldShowTo` "TIPH[MyVal 20,1,False,3.5]"+  tip4 `shouldShowTo` "TIPH[MyVal 20,21,True,3.5]"+  tip5 `shouldShowTo` "TIPH[MyVal 21,1,True,3.5]"+  let tip6w = runWriter (ttipM op6w tip1)+  fst tip6w `shouldShowTo` "TIPH[MyVal 5,1,True,3.5]"+  snd tip6w `shouldBe` "MyVal is now MyVal 5"+
− examples/Joy.hs 
@@ -1,287 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-{-# OPTIONS -fallow-overlapping-instances #-}-{-# OPTIONS -fallow-undecidable-instances #-}----Joy implemented in Haskell... extensible embedded language...--module Joy where--import MainGhcGeneric1---- Building non-empty lists--type HOne = HSucc HZero-hOne :: HOne-hOne = undefined-type HTwo = HSucc HOne-hTwo :: HTwo-hTwo = undefined-type HThree = HSucc HTwo-hThree :: HThree-hThree = undefined--end :: HNil-end = hNil--instance HList s => Apply HNil s s where-	apply _ s = s-instance (HList s,HList s',HList l,Apply a s s',Apply l s' s'') => Apply (HCons a l) s s'' where-	apply (HCons a l) s = apply l (apply a s :: s')-instance HList s => Apply HZero s (HCons HZero s) where-	apply _ s = hCons hZero s-instance (HNat a,HList s) => Apply (HSucc a) s (HCons (HSucc a) s) where-	apply a s = hCons a s--data Lit a = Lit a-lit :: a -> Lit a-lit a = Lit a-unl :: Lit a -> a-unl (Lit a) = a-instance Show a => Show (Lit a) where-	showsPrec _ (Lit a) = showChar '[' . shows a . showChar ']'-instance HList s => Apply (Lit a) s (HCons a s) where-	apply (Lit a) s = hCons a s--class (HBool b,HList s) => HIfte b t f s s' | b t f s -> s' where-	hIfte :: b -> t -> f -> s -> s'-instance (HList s,Apply t s s') => HIfte HTrue t f s s' where-	hIfte _ t _ s = apply t s-instance (HList s,Apply f s s') => HIfte HFalse t f s s' where-	hIfte _ _ f s = apply f s--data Ifte-ifte :: Ifte-ifte = undefined-instance Show Ifte where-	showsPrec _ _ = showString "If"-instance (Apply b s r,HHead r b',HIfte b' t f s s')-	=> Apply Ifte (f :*: t :*: b :*: s) s' where-	apply _ (HCons f (HCons t (HCons b s))) = hIfte (hHead (apply b s :: r) :: b') t f s--data Nul-nul :: Nul-nul = undefined-instance Show Nul where-	showsPrec _ _ = showString "Nul"-instance HList s => Apply Nul (HCons HZero s) (HCons HTrue s) where-	apply _ (HCons _ s) = hCons hTrue s-instance HList s => Apply Nul (HCons (HSucc n) s) (HCons HFalse s) where-	apply _ (HCons _ s) = hCons hFalse s--data EQ-eq :: EQ-eq = undefined-instance Show EQ where-	showsPrec _ _ = showString "Eq"-instance (HList s,TypeEq a b t) => Apply EQ (HCons a (HCons b s)) (HCons t s) where-	apply _ (HCons a (HCons b s)) = hCons (typeEq a b) s--data Dip-dip :: Dip-dip = undefined-instance Show Dip where-	showsPrec _ _ = showString "Dip"-instance (HList s,HList s',Apply a s s') => Apply Dip (HCons a (HCons b s)) (HCons b s') where-	apply _ (HCons a (HCons b s)) = hCons b (apply a s)--data Dup -dup :: Dup-dup = undefined-instance Show Dup where-	showsPrec _ _ = showString "Dup"-instance HList s => Apply Dup (HCons a s) (HCons a (HCons a s)) where-	apply _ s@(HCons a _) = hCons a s--data Pop-pop :: Pop-pop = undefined-instance Show Pop where-	showsPrec _ _ = showString "Pop"-instance HList s => Apply Pop (HCons a s) s where-	apply _ (HCons _ s) = s--data Swap-swap :: Swap-swap = undefined-instance Show Swap where-	showsPrec _ _ = showString "Swap"-instance HList s => Apply Swap (HCons a (HCons b s)) (HCons b (HCons a s)) where-	apply _ (HCons a (HCons b s)) = hCons b (hCons a s)--data Suc-suc :: Suc-suc = undefined-instance Show Suc where-	showsPrec _ _ = showString "Suc"-instance (HNat a,HList s) => Apply Suc (HCons a s) (HCons (HSucc a) s) where-	apply _ (HCons _ s) = hCons (undefined::HSucc a) s--data Pre-pre :: Pre-pre = undefined-instance Show Pre where-	showsPrec _ _ = showString "Pre"-instance (HNat a,HList s) => Apply Pre (HCons (HSucc a) s) (HCons a s) where-	apply _ (HCons _ s) = hCons (undefined::a) s--data Add-add :: Add-add = undefined-instance Show Add where-	showsPrec _ _ = showString "Add"-instance (HList s,HAdd a b c) => Apply Add (HCons a (HCons b s)) (HCons c s) where-	apply _ (HCons _ (HCons _ s)) = hCons (hAdd (undefined::a) (undefined::b)) s--class (HNat a,HNat b) => HAdd a b c | a b -> c where-	hAdd :: a -> b -> c-instance HAdd HZero HZero HZero where-	hAdd _ _ = hZero-instance HNat b => HAdd HZero (HSucc b) (HSucc b) where-	hAdd _ b = b-instance HNat a => HAdd (HSucc a) HZero (HSucc a) where-	hAdd a _ = a-instance (HNat (HSucc a),HNat (HSucc b),HNat c,HAdd a b c)-	=> HAdd (HSucc a) (HSucc b) (HSucc (HSucc c)) where-	hAdd _ _ = hSucc $ hSucc $ hAdd (undefined::a) (undefined::b)--data Sub-sub :: Sub-sub = undefined-instance Show Sub where-	showsPrec _ _ = showString "Sub"-instance (HList s,HSub a b c) => Apply Sub (HCons b (HCons a s)) (HCons c s) where-	apply _ (HCons _ (HCons _ s)) = hCons (hSub (undefined::a) (undefined::b)) s--class (HNat a,HNat b) => HSub a b c | a b -> c where-	hSub :: a -> b -> c-instance HSub HZero HZero HZero where-	hSub _ _ = hZero-instance HNat a => HSub (HSucc a) HZero (HSucc a) where-	hSub a _ = a-instance HNat a => HSub HZero (HSucc a) HZero where-	hSub _ _ = hZero-instance (HSub a b c) => HSub (HSucc a) (HSucc b) c where-	hSub _ _ = hSub (undefined::a) (undefined::b)-	-data Mult-mult :: Mult-mult = undefined-instance Show Mult where-	showsPrec _ _ = showString "Mult"-instance (HList s,HMult a b c) => Apply Mult (HCons a (HCons b s)) (HCons c s) where-	apply _ (HCons _ (HCons _ s)) = hCons (hMult (undefined::a) (undefined::b)) s--class (HNat a,HNat b) => HMult a b c | a b -> c where-	hMult :: a -> b -> c-instance HNat b => HMult HZero b HZero where-	hMult _ _ = hZero-instance (HMult a b s,HAdd b s s') => HMult (HSucc a) b s' where-	hMult _ _ = hAdd (undefined::b) (hMult (undefined::a) (undefined::b) :: s)--square = dup .*. mult .*. hNil-cube = mult .*. mult .*. dup .*. dup .*. hNil--data I-i :: I-i = undefined-instance Show I where-	showsPrec _ _ = showString "I"-instance Apply I HNil HNil where-	apply _ _ = hNil-instance (HList s,Apply a s s') => Apply I (HCons a s) s' where-	apply _ (HCons a s) = apply a s--data Primrec = Primrec deriving Show-primrec :: Primrec-primrec = undefined-instance Apply z s s' => Apply Primrec (HCons nz (HCons z (HCons HZero s))) s' where-	apply _ (HCons _ (HCons z (HCons _ s))) = apply z s-instance (HList s,Apply Primrec (HCons nz (HCons z (HCons n (HCons (HSucc n) s)))) s',Apply nz s' s'')-	=> Apply Primrec (HCons nz (HCons z (HCons (HSucc n) s))) s'' where-	apply _ (HCons nz (HCons z s@(HCons _ _))) = apply nz (apply Primrec (hCons nz (hCons z (hCons (undefined::n) s))))--data Times-times :: Times-times = undefined-instance Show Times where-	showsPrec _ _ = showString "Times"-instance HList s => Apply Times (HCons p (HCons HZero s)) s where-	apply _ (HCons _ (HCons _ s)) = s-instance (HNat n,HList s,HList s',Apply p s s',Apply Times (HCons p (HCons n s')) s'')-	=> Apply Times (HCons p (HCons (HSucc n) s)) s'' where-	apply _ (HCons p (HCons _ s)) = apply times (hCons p (hCons (undefined::n) (apply p s)))--class (HBool f,HList s) => HGenrec f r1 r2 b t s s'' | f r1 r2 b t s -> s'' where-	hGenrec :: f -> r1 -> r2 -> b -> t -> s -> s''-instance (HList s,Apply t s s') => HGenrec HTrue r1 r2 b t s s' where-	hGenrec _ _ _ _ t s = apply t s-instance (HList s,HList s',Apply r1 s s',-	Apply (HCons (Lit (HCons (Lit b) (HCons (Lit t) (HCons (Lit r1) (HCons (Lit r2) (HCons Genrec HNil)))))) (HCons r2 HNil)) s' s'')-	=> HGenrec HFalse r1 r2 b t s s'' where-	hGenrec _ r1 r2 b t s = apply (hCons (lit (hCons (lit b) (hCons (lit t) (hCons (lit r1) (hCons (lit r2) (hCons genrec hNil)))))) (hCons r2 hNil)) (apply r1 s :: s') --data Genrec-genrec :: Genrec-genrec = undefined-instance Show Genrec where-	showsPrec _ _ = showString "Genrec"-instance (Apply b s s',HHead s' b',HGenrec b' r1 r2 b t s s'')-	=> Apply Genrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where-	apply _ (HCons r2 (HCons r1 (HCons t (HCons b s))))-		= hGenrec (hHead (apply b s :: s') :: b') r1 r2 b t s--class (HBool f,HList s) => HLinrec f b t r1 r2 s s' | f b t r1 r2 s -> s' where-	hLinrec :: f -> b -> t -> r1 -> r2 -> s -> s'-instance (HList s,Apply t s s') => HLinrec HTrue b t r1 r2 s s' where-	hLinrec _ _ t _ _ s = apply t s-instance (HList s,HList s',Apply r1 s s',-	Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s')))) s'',Apply r2 s'' s''')-	=> HLinrec HFalse b t r1 r2 s s''' where-	hLinrec _ b t r1 r2 s = apply r2 (apply linrec (hCons r2 (hCons r1 (hCons t (hCons b (apply r1 s :: s'))))) :: s'')--data Linrec-linrec :: Linrec-linrec = undefined-instance Show Linrec where-	showsPrec _ _ = showString "Linrec"-instance (Apply b s s',HHead s' b',HLinrec b' b t r1 r2 s s'') => Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where-	apply _ (HCons r2 (HCons r1 (HCons t (HCons b s)))) = hLinrec (hHead (apply b s :: s') :: b') b t r1 r2 s--data Fact-fact :: Fact-fact = undefined-instance Show Fact where-	showsPrec _ _ = showString "Fact"-instance (HList s,Apply (HCons (Lit (HCons (Lit HZero) (HCons EQ HNil)))-	(HCons (Lit (HCons Pop (HCons (Lit HOne) HNil)))-	(HCons (Lit (HCons Dup-	(HCons (Lit HOne)-	(HCons Sub (HCons Fact (HCons Mult HNil))))))-	(HCons Ifte HNil)))) s s') => Apply Fact s s' where-	apply _ s = apply fac1 s--fac1 = hCons (lit (hCons (lit hZero) (hCons eq hNil)))-	(hCons (lit (hCons pop (hCons (lit hOne) hNil)))-	(hCons (lit (hCons dup (hCons (lit hOne) (hCons sub (hCons fact (hCons mult hNil))))))-	(hCons ifte hNil)))--fac2 = lit (hOne .*. hOne .*. end)-	.*. dip .*. lit (dup .*. lit mult .*. dip .*. suc .*. end)-	.*. times .*. pop .*. end--fac3 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end)-	.*. lit (i .*. mult .*. end) .*. genrec .*. end--fac4 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end)-	.*. lit mult .*. linrec .*. end--fac5 = lit hOne .*. lit mult .*. primrec .*. end--main :: IO ()-main = do-	putStrLn $ show $ apply (lit hThree .*. fac1 .*. end) end-	putStrLn $ show $ apply i (fac2 .*. hThree .*. end)-	putStrLn $ show $ apply i (fac3 .*. hThree .*. end)-	putStrLn $ show $ apply i (fac4 .*. hThree .*. end)-	putStrLn $ show $ apply i (fac5 .*. hThree .*. end)-
− examples/MainGhcGeneric1.hs 
@@ -1,341 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverlappingInstances#-}-{-# LANGUAGE UndecidableInstances#-}-{-# LANGUAGE ScopedTypeVariables #-}--{---   (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.--   Note: even though there are no overlapping instances in *this*-   module, one must still enable overlapping instances here; otherwise-   overlapping (for type equality) is not resolved properly for the-   imported modules.---}--module MainGhcGeneric1 (--{-- module Datatypes2,- module Data.HList.CommonMain,- module Data.HList.TypeEqO,- module Data.HList.Label3,--- mainExport--}--) where--import Datatypes2-import Data.HList.CommonMain -- hiding (HDeleteMany, hDeleteMany)--{--import Data.HList.RecordAdv-import Data.HList.RecordP--}----- ----------------------------------------------------------------------------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 (TIP (HCons 1 HNil))-  print $ null $ hOccurs (TIP (HCons [] HNil))-  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 is 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--tuple :: forall e1 e2 n l n2.-    (HDeleteAtHNat n l,-     HOccurs e1 (TIP l),-     HOccurs e2 (TIP (HDeleteAtHNatR n l)),-     HType2HNat e1 l n,-     -- extra, not inferred-     HType2HNat e2 l n2,-     HOccurs e1 (TIP (HDeleteAtHNatR n2 l))-    ) => TIP l -> (e1,e2)-tuple (TIP l) = let-                 x  = hOccurs (TIP l)-                 l' = hDeleteAt (undefined::Proxy e1) l-                 y  = hOccurs (TIP l')-                in (x,y)---- | A specific tuple--- Need to import an instance of TypeEq to be able to run the examples-oneTrue :: TIP '[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-  -- requires explicit type for tuple-  print $ ((+) (1::Int)) $ snd $ tuple oneTrue---myTipyCow = TIP angus--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 $ hExtend 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 .*. tipyDelete (undefined::Proxy 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 (hLabels (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 = [Key,Name,Breed,Price]--testTIC = do-  putStrLn "\ntestTIC"-  print $ myCol-  print $ (unTIC myCol :: Maybe Breed)-  print $ (unTIC myCol :: Maybe Price)- where-  myCol = mkTIC Cow :: TIC AnimalCol--{---myCol = mkTIC Cow :: TIC AnimalCol--*TIC> unTIC myCol :: Maybe Breed-Just Cow-*TIC> unTIC myCol :: Maybe Price-Nothing-*TIC> mkTIC "42" :: TIC AnimalCol-Type error ...-*TIC> unTIC myCol :: Maybe String-Type error ...---}--testVariant = (testVar1,(testVar2,(testVar3)))- where-  animalVar =  key   .=. (Proxy::Proxy Integer)-           .*. name  .=. (Proxy::Proxy String)-           .*. breed .=. (Proxy::Proxy Breed)-           .*. emptyRecord-  testVar1 = mkVariant name "angus" animalVar-  testVar2 = unVariant key testVar1-  testVar3 = unVariant name testVar1--{---- ----------------------------------------------------------------------------main = mainExport-mainExport-   = print $   ( testHArray-               , ( testHOccurs-               , ( testTypeIndexed-               , ( testTuple-               , ( testTIP--               , ( testRecords-               , ( testRecordsP-               , ( testTIC-               , ( testVariant-               )))))))))---}--main = do-       testListBasic-       testHArray-       testHOccurs-       testTypeIndexed-       testTuple-       testTIP-       testRecords-       testTIC
− examples/MainGhcGeneric1.out 
@@ -1,54 +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-<Cannot show TIC content!>-Just Cow-Nothing
− examples/MainGhcGeneric1.ref 
@@ -1,54 +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-<Cannot show TIC content!>-Just Cow-Nothing
− examples/MainGhcGeneric2.hs 
@@ -1,22 +0,0 @@-{---   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Included for completeness' sake.-   The TypeEqBoolGeneric2.hs implementation is demonstrated.---}--module MainGhcGeneric2 where--import Data.HList---{-----------------------------------------------------------------------------}--main = print ( hEq True False-             , hEq True "True"-             )---{-----------------------------------------------------------------------------}
− examples/MainGhcGeneric2.out 
@@ -1,1 +0,0 @@-(HTrue,HFalse)
− examples/MainGhcGeneric2.ref 
@@ -1,1 +0,0 @@-(HTrue,HFalse)
− examples/MainPatternMatch.hs 
@@ -1,78 +0,0 @@-{-# 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--makeLabels ["px","py"]---- Labels--- The more convenient labels, Label4.hs, need -fallow-overlapping-instances--- The less convenient label representation needs fewer extensions.--- We go for more convenient...--{--data PtX; px = proxy::Proxy PtX-data PtY; py = proxy::Proxy PtY--}---accessor r f = r # f---- 1D points-point1 x = -       px .=. x-   .*. emptyRecord---- 2D points-point2 x y = -       px .=. x-   .*. py .=. (y + 10)-   .*. emptyRecord----- Record-polymorphic function, which illustrates record pattern-matching,--- with the help of generalized guards-foo p | 0 <- p # px = "X is zero"-foo _ = "something else"--test1  = foo (point1 0)     -- X is zero-test1' = foo (point1 42)    -- something else-test2 = foo (point2 10 20)  -- something else--- inline construction of the record-test3 = foo (py .=. False .*. px .=. 0 .*. emptyRecord) -- X is zero--main = do-       putStrLn test1-       putStrLn test1'-       putStrLn test2-       putStrLn test3
− examples/MainPatternMatch.out 
@@ -1,4 +0,0 @@-X is zero-something else-something else-X is zero
− examples/MainPatternMatch.ref 
@@ -1,4 +0,0 @@-X is zero-something else-something else-X is zero
− examples/MainPosting-040607.hs 
@@ -1,302 +0,0 @@-{-# 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---- These are your two "implementations".--data MyImplementation1 = MyImplementation1 Int deriving (Show,Eq,Typeable)-data MyImplementation2 = MyImplementation2 Int deriving (Show,Eq,Typeable)----- This is your interface class and the two instances.--class MyInterface a - where-  foo :: a -> Int--instance MyInterface MyImplementation1- where-  foo (MyImplementation1 i) = i--instance MyInterface MyImplementation2- where-  foo (MyImplementation2 i) = i----- Here is your list,--- without the noise you don't like.--list1 =  MyImplementation1 10-     .*. MyImplementation2 20-     .*. HNil----- If you like, this is the type, but it is not needed.--- This list is not opaque. Less trouble in our experience.--- (When compared to using existentials.)--type MyList = HList '[MyImplementation1, MyImplementation2]----- Perhaps you want to make sure that you have a list of implementations--- of MyInterface. Here is *one* way to do it. But you don't need to do it--- because this will be automatically checked (statically) whenever you--- try to use the fooISH interface.--class ListOfMyInterface l- where-  listOfMyInterface :: HList l -> HList l-  listOfMyInterface = id--instance ListOfMyInterface '[]-instance ( MyInterface e-         , ListOfMyInterface l-         )-      =>   ListOfMyInterface (e ': l)----- So you apply the id function with the side effect of statically --- ensuring that you are given a list of implementations of MyInterface.--list2 :: MyList-list2 = listOfMyInterface list1----- Here is another way to do it.--- You apply a heterogenous fold to the list.--- This second solution is just for fun.--data ImplementsMyInterface = ImplementsMyInterface--instance (- x ~ (e,HList l),- y ~ (HList (e ': l))- ) => ApplyAB ImplementsMyInterface x y- where-  applyAB _ (e,l) = HCons e l--myKindOfList l = hFoldr ImplementsMyInterface HNil l----- Basically again you apply the identity function; a deep one this time.--list3 :: MyList-list3 = myKindOfList list1----- Your equality can indeed not work because the existentially quantified--- implementations are of course opaque. You cannot compare apples and--- oranges. Equality of heterogeneous lists is trivial; it is just derived.--- To make it a little bit more interesting, we can consider heterogeneous--- or stanamic equality. So you will always get a Boolean even for lists--- of different types. See below.----- Here is your bar function.--- It uses one sort of maps on heterogeneous lists.--bar :: MyList -> Int-bar = sum . hMapOut Foo--data Foo = Foo -- type driver for class-level application--instance (MyInterface e, int ~ Int) => ApplyAB Foo e int- where-  applyAB _ e = foo e----- Yet another heterogeneous equality.--- Just for fun.----yaHEq :: (Typeable a, Typeable b, Eq a) => a -> b -> Bool-yaHEq a b = case cast b of-             Just a' -> a == a'-             Nothing -> False---- Yet another heterogeneous list; a bit less typed.-data AnyMyInterface = forall a. ( Eq a-                                , Typeable a-                                , MyInterface a-                                ) => AnyMyInterface a--type MyList' = [AnyMyInterface]-list4 = [ AnyMyInterface $ MyImplementation1 10-        , AnyMyInterface $ MyImplementation1 10-        ]-list5 = [ AnyMyInterface $ MyImplementation1 10-        , AnyMyInterface $ MyImplementation2 10-        ]-list6 = [ AnyMyInterface $ MyImplementation1 10-        , AnyMyInterface $ MyImplementation2 20-        ]--instance Eq AnyMyInterface- where-  (AnyMyInterface x) == (AnyMyInterface y) = x `yaHEq` y---{---Demo follows.--*Main> :l gh-users-040607.hs-Compiling FakePrelude      ( ./FakePrelude.hs, interpreted )-Compiling HType            ( HType.hs, interpreted )-Compiling HList            ( ./HList.hs, interpreted )-Compiling HArray           ( ./HArray.hs, interpreted )-Compiling HTypeDriven      ( ./HTypeDriven.hs, interpreted )-Compiling Main             ( gh-users-040607.hs, interpreted )-Ok, modules loaded: Main, HTypeDriven, HArray, HList, HType, FakePrelude.-*Main> list1-HCons (MyImplementation1 10) (HCons (MyImplementation2 20) HNil)-*Main> bar list1-30-*Main> list1 == list1-True-*Main> list1 `hStagedEq` hReverse list1-False-*Main> list4!!0 == list4!!1-True-*Main> list5!!0 == list5!!1-False-*Main> list6!!0 == list6!!1-False---}--main = print-             ( list1-           , ( list1 == list1-          --  , ( list1 `hStagedEq` hReverse list1-           , ( list4!!0 == list4!!1-           , ( list5!!0 == list5!!1-           , ( list6!!0 == list6!!1-           )))))--{---Mike Aizatsky wrote:-->Hello,->->I'm in process of rewriting the old Java application. While this is for sure->lots of fun, there're some problems in modeling the java interfaces.->->Here's the common Java scenario (it's actually the pattern, common for all->OO-languages, so there should be no problems in understanding it):->->interface MyInterface {->	int foo();->}->->class MyImplementation1 implements MyInterface { int foo() {...} }->class MyImplementation2 implements MyInterface { int foo() {...} }->->And, somewhere in the code:->->int bar(List<MyInterface> list) { .... sum up all foos & return .... }->->I've found quite an obvious translation of it to Haskell:->->module Ex where->->class MyInterface a where->	foo :: a -> Int->->data AnyMyInterface = forall a. (MyInterface a) => AnyMyInterface a->->instance MyInterface AnyMyInterface where->	foo (AnyMyInterface a) = foo a->->->data MyImplementation1 = MyImplementation1 Int->->instance MyInterface MyImplementation1 where->	foo(MyImplementation1 i) = i->->data MyImplementation2 = MyImplementation2 Int->->instance MyInterface MyImplementation2 where->	foo(MyImplementation2 i) = i->->->type MyList = [AnyMyInterface]->->list1 :: MyList->list1 = [AnyMyInterface (MyImplementation1 10), AnyMyInterface->(MyImplementation2 20)]->->bar :: MyList -> Int->bar l = sum (map foo l)->->->However there're some problems with this way to go:->->1. It's quite verbose. I already have a dozen of such interfaces, and I'm a->bit tired of writing all this AnyInterface stuff. I'm already thinking about->writing the Template Haskell code to generate it. Is anything similar->available around?->->2. I don't like the fact that I need to wrap all implementations inside the->AnyMyInterface when returning values (see list1). Any way to get rid of it?->->3. The big problem. I can't make AnyMyInterface to be an instance of Eq. I->write:->->data AnyMyInterface = forall a. (MyInterface a, Eq a) => AnyMyInterface a->instance Eq AnyMyInterface where->	(==) (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2->->And it gives me an error (ghc 6.2.1):->->    Inferred type is less polymorphic than expected->        Quantified type variable `a1' is unified with another quantified->type variable `a'->    When checking an existential match that binds->        a1 :: a->        a2 :: a1->    The pattern(s) have type(s): AnyMyInterface->                                 AnyMyInterface->    The body has type: Bool->    In the definition of `==':->        == (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2->    In the definition for method `=='->->Honestly, I don't understand what's going on. My guess is that the problem->comes from the fact that a1 & a2 might be of different Implementations. Is->it right? Any way to define the Eq instance of AnyMyInterface?->->->So, it looks like that existential data types do allow you to mimic the->polymorphic data structures, found in OO languages. But it results in much->more verbose code. Are there any other ways to do the same stuff?->->_______________________________________________->Glasgow-haskell-users mailing list->Glasgow-haskell-users@haskell.org->http://www.haskell.org/mailman/listinfo/glasgow-haskell-users->---}
− examples/MainPosting-040607.out 
@@ -1,1 +0,0 @@-(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False))))
− examples/MainPosting-040607.ref 
@@ -1,1 +0,0 @@-(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False))))
− examples/MainPosting-051106.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Main where---- Needed for a reply to the Haskell mailing list--import Data.HList.CommonMain hiding (Comp(..))--main = do-    print $ comp "abc"-    print $ (hComposeList test2 "abc" :: Int) -- definition in HList now--test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil))-test2 = length .*. (+1) .*. (*2) .*. HNil--data Comp--{- simpler class. wouldn't work with test2. The original HFoldr won't work with- - Apply anymore.-instance Apply Comp (x -> y,y -> z)- where-  type ApplyR Comp (x -> y,y -> z) = x -> z-  apply _ (f,g) = g . f-  -}--instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz)-    => ApplyAB Comp xyz xz- where-  applyAB _ (f,g) = g . f---- Function composition based on type code works.--comp  = hFoldr (undefined::Comp) (id::Int -> Int) test---- Function composition based on normal polymorphism doesn't--- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test--{---From Ralf.Lammel at microsoft.com  Mon Nov  7 00:11:01 2005-From: Ralf.Lammel at microsoft.com (Ralf Lammel)-Date: Sun Nov  6 23:50:27 2005-Subject: [Haskell-cafe] Type classes and hFoldr from HList-Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com>--Hi Greg,--Since hfoldr is right-associative, I prefer to reorder your list of-functions as follows:--> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons-((*2)::(Int->Int)) HNil))--Note that I also annotated length with its specific type.-(If you really wanted to leave things more polymorphic, you would need-to engage in TypeCast.)--Providing a specific Apply instance for (.) is not necessary, strictly-necessary. We could try to exploit the normal function instance for-Apply.--Let me recall that one here for convenience:-->instance Apply (x -> y) x y-> where->  apply f x = f x--Let me also recall the hFoldr instances:-->class HList l => HFoldr f v l r | f v l -> r-> where->  hFoldr :: f -> v -> l -> r-->instance HFoldr f v HNil v-> where->  hFoldr _ v _ = v-->instance ( HFoldr f v l r->         , Apply f (e,r) r'->         )->      => HFoldr f v (HCons e l) r'-> where->  hFoldr f v (HCons e l) = apply f (e,hFoldr f v l)---To fit in (.), we would flip and uncurry it.-So we could try:--comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test--This wouldn't work.-The trouble is the required polymorphism of the first argument of-hFoldr.-The type of that argument as such is polymorphic.-However, this polymorphism does not survive type class parameterization.-You see this by looking at the HCons instance of HFoldr.-The different occurrences of "f" would need to be used at different-types.-This would only work if the type class parameter f were instantiated by-the polymorphic type of (uncurry (flip (.))). (And even then we may need-something like TypeCast.)--What you can do is define a dedicated *type code* for composition.--comp  = hFoldr (undefined::Comp) (id::Int -> Int) test--data Comp--instance Apply Comp (x -> y,y -> z) (x -> z)- where-  apply _ (f,g) = g . f---Ralf---> -----Original Message------> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe--> bounces@haskell.org] On Behalf Of Greg Buchholz-> Sent: Sunday, November 06, 2005 7:01 PM-> To: haskell-cafe@haskell.org-> Subject: [Haskell-cafe] Type classes and hFoldr from HList-> -> ->   I was playing around with the HList library from the paper...-> ->     Strongly typed heterogeneous collections->     http://homepages.cwi.nl/~ralf/HList/-> -> ...and I thought I'd try to fold the composition function (.) through-a-> heterogeneous list of functions, using hFoldr...-> -> >{-# OPTIONS -fglasgow-exts #-}-> >{-# OPTIONS -fallow-undecidable-instances #-}-> >-> >import CommonMain-> >-> >main = print $ comp "abc"-> >-> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons-length-> HNil))-> >-> >comp = hFoldr (.) id test-> >-> >instance Apply (a -> b -> c -> d) (a, b) (c -> d)-> >    where-> >        apply f (a,b) = f a b-> -> ...but it fails with the following type error...-> -> ]Compiling Main             ( compose.hs, interpreted )-> ]-> ]compose.hs:10:7:-> ]    No instances for (Apply ((b -> c) -> (a -> b) -> a -> c)-> ]                            (Int -> Int, r)-> ]                            ([Char] -> a3),-> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) (Int ->-Int,-> r1) r,-> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] ->-> Int, a1 ->a1) r1)-> ]      arising from use of `hFoldr' at compose.hs:10:7-12-> ]    Probable fix:-> ]      add an instance declaration for (Apply ((b -> c) -> (a -> b) ->-a --> > c)-> ]                                             (Int -> Int, r)-> ]                                             ([Char] -> a3),-> ]                                       Apply ((b -> c) -> (a -> b) ->-a --> > c)-> ](Int -> Int, r1) r,-> ]                                       Apply ((b -> c) -> (a -> b) ->-a --> > c)-> ]([a2] -> Int, a1 -> a1) r1)-> ]    In the definition of `comp': comp = hFoldr (.) id test-> -> ...Anyway, I couldn't quite tell whether I was using hFoldr-incorrectly,-> or if I needed to have more constraints placed on the construction of-> "test", or if needed some sort of type-level function that resolves...-> -> Apply ((b -> c) -> (a -> b) -> a -> c)-> -> ...into (a -> c), or something else altogether.  I figured someone-might-> be able to help point me in the right direction.---}
− examples/MainPosting-051106.out 
@@ -1,2 +0,0 @@-8-8
− examples/MainPosting-051106.ref 
@@ -1,2 +0,0 @@-8
-8
+ examples/Properties.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# OPTIONS_GHC -freduction-depth=100 #-}+#else+{-# OPTIONS_GHC -fcontext-stack=100 #-}+#endif+{-# OPTIONS_GHC -fno-warn-deprecations #-} -- ghc-7.8 has no Typeable (x :: Symbol), so use OldTypeable+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Description: quickcheck tests+--+-- Many of the tests here use quickcheck. The lengths of the hlists+-- involved exhaustively cover a small range, while the elements+-- are random samples.+module Main where++import Test.Hspec++import Properties.LengthDependentSplice+import Properties.LengthIndependent+import Properties.KW++main = hspec $ do+   hl0+   hl1_2_3+   kwSpecs
+ examples/Properties/Common.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+module Properties.Common where++import Data.HList.CommonMain+import Test.QuickCheck+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++hListE :: [ExpQ] -> ExpQ+hListE = foldr (\a b -> [| $a `HCons` $b |]) [| HNil |]++hNatE :: Int -> ExpQ+hNatE n = foldr appE [| hZero |] (replicate n [| hSucc |])++hNatT :: Int -> TypeQ+hNatT n = foldr appT [t| HZero |] (replicate n [t| HSucc |])+++lx = Label :: Label "x"+ly = Label :: Label "y"+lz = Label :: Label "z"++data BinF b = BinF (b -> b -> b)++instance (bb ~ (b, b), b ~ b') => ApplyAB (BinF b') bb b where+    applyAB (BinF f) = uncurry f+++-- | A more general type than @===@ used to+-- ensure that both sides can infer the same type+eq :: (Show a, Show b, HCast a b, HCast b a, Eq a, Eq b) => a -> b -> Property+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),+        pn ~ Proxy n) => ApplyAB HSuccF pn psn where+    applyAB _ = hSucc+++data HSplitAtAppend l = HSplitAtAppend (HList l)+instance (pn ~ Proxy n,+          HSplitAt n l a b,+          HAppend (HList a) (HList b),+          y ~ HAppendR (HList a) (HList b)) => ApplyAB (HSplitAtAppend l) pn y where+    applyAB (HSplitAtAppend l) n = case hSplitAt n l of+                                     (a,b) -> hAppend a b++++data ConstTrue+instance HEqByFn ConstTrue+instance HEqBy ConstTrue x y True++data ConstFalse+instance HEqByFn ConstFalse+instance HEqBy ConstFalse x y False+++instance Arbitrary a => Arbitrary (Tagged t a) where+    arbitrary = fmap Tagged arbitrary++instance Arbitrary (HList '[]) where+    arbitrary = return HNil++instance (Arbitrary x, Arbitrary (HList xs)) => Arbitrary (HList (x ': xs)) where+    arbitrary = do+      x <- arbitrary+      xs <- arbitrary+      return $ x `HCons` xs++instance (Arbitrary x, Arbitrary (Variant (Tagged t y ': ys)),+          HExtend (Tagged s (Maybe x)) (Variant (Tagged t y ': ys)),+          HNat2Integral (HLength ys))+        => Arbitrary (Variant (Tagged s x ': Tagged t y ': ys)) where+    arbitrary = do+      let nys = hNat2Integral (Proxy :: Proxy (HLength ys))+      x :: Maybe x <- frequency [ (1, Just <$> arbitrary), (nys+1, return Nothing) ]+      yys :: Variant (Tagged t y ': ys) <- arbitrary+      return $ Tagged x .*. yys++instance Arbitrary z => Arbitrary (Variant '[Tagged t z]) where+    arbitrary = do+      z <- arbitrary+      return $ mkVariant1 Label z++instance (CoArbitrary x, CoArbitrary (Variant (y ': z)),+         HNat2Integral n, n ~ HLength (y ': z)) => CoArbitrary (Variant (x ': y ': z)) where+    coarbitrary v = case splitVariant1' v of+          Left x -> variant (hNat2Integral (Proxy :: Proxy n) :: Int) . coarbitrary x+          Right v' -> coarbitrary v'++instance (CoArbitrary v, Unvariant '[Tagged t v] v) => CoArbitrary (Variant '[Tagged t v]) where+    coarbitrary v = coarbitrary (unvariant v)++-- | This type is used to make unique types with two members.+--+-- > (BoolN True :: BoolN "x") /= (BoolN True :: BoolN "y")+--+-- is a type error+newtype BoolN (n :: Symbol) = BoolN Bool+  deriving (Eq,CoArbitrary,Arbitrary,Show,Read,Ord)++boolN next = simple $ iso (\(BoolN x) -> x) BoolN next++instance Monoid (BoolN n) where+    mempty = BoolN (getAll mempty)+#if __GLASGOW_HASKELL__ <= 906+    mappend (BoolN x) (BoolN y) = BoolN (getAll (mappend (All x) (All y)))++instance Semigroup (BoolN n) where (<>) = mappend+#else++instance Semigroup (BoolN n) where+  (BoolN x) <> (BoolN y) = BoolN (getAll (mappend (All x) (All y)))+#endif++#if !MIN_VERSION_QuickCheck(2,9,0)+instance Arbitrary (Identity (BoolN n)) where+    arbitrary = fmap return arbitrary+#endif+++data HSortF = HSortF+instance (x ~ Record xs,+          y ~ Record ys,+          HRLabelSet ys,+          HSort xs ys) => ApplyAB HSortF x y where+  applyAB _ (Record x) = mkRecord (hSort x)
+ examples/Properties/KW.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+module Properties.KW where+++import Properties.Common+import Test.QuickCheck+import Data.HList.CommonMain+import Test.Hspec+++kwSpecs = describe "kw" $ do+    {- with NoMonoLocalBinds+     - /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:59:15: error:ghc: panic! (the 'impossible' happened)+  (GHC version 8.0.2 for x86_64-unknown-linux):+	No skolem info: k_aqoh[sk]++        with MonoLocalBinds, I think the error is the same as in earlier versions++        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:62:15: error:+            • Couldn't match type ‘'[Tagged "x" (BoolN "x")]’ with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR (Tagged "x" (BoolN "x")) (Record '[])+            • In the first argument of ‘f2’, namely+                ‘(lx .=. x2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (lx .=. x2 .*. emptyRecord)’+              In the expression: f2 (lx .=. x2 .*. emptyRecord) `eq` f1 x2 y+                     +        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:63:15: error:+            • Couldn't match type ‘'[Tagged "y" (BoolN "y")]’ with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR (Tagged "y" (BoolN "y")) (Record '[])+            • In the first argument of ‘f2’, namely+                ‘(ly .=. y2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (ly .=. y2 .*. emptyRecord)’+              In the expression: f2 (ly .=. y2 .*. emptyRecord) `eq` f1 x y2+                     +        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:64:15: error:+            • Couldn't match type ‘'[Tagged "x" (BoolN "x"),+                                     Tagged "y" (BoolN "y")]’+                             with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR+                               (Tagged "x" (BoolN "x")) (Record '[Tagged "y" (BoolN "y")])+            • In the first argument of ‘f2’, namely+                ‘(lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’+              In the expression:+                f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord) `eq` f1 x2 y2+                     +        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:65:15: error:+            • Couldn't match type ‘'[Tagged "y" (BoolN "y"),+                                     Tagged "x" (BoolN "x")]’+                             with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR+                               (Tagged "y" (BoolN "y")) (Record '[Tagged "x" (BoolN "x")])+            • In the first argument of ‘f2’, namely+                ‘(ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’+              In the expression:+                f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2++-}+    it "f1" $ property $ do+      (f1 :: BoolN "x" -> BoolN "y") <- arbitrary+      x :: BoolN "x" <- arbitrary+      x2 :: BoolN "x" <- arbitrary+      let f2 (Label :: Label "x") x () = f1 x+          f = f2 .*. recToKW [pun| x |]+      return $ conjoin+        [ kw f lx x2 () `eq` f1 x2,+          kw f () `eq` f1 x ]++    -- a function of two arguments can be made into a keyword function+    it "f2" $ property $ do+      (f1 :: BoolN "x" -> BoolN "y" -> BoolN "z") <- arbitrary+      x :: BoolN "x" <- arbitrary+      x2 :: BoolN "x" <- arbitrary+      y :: BoolN "y" <- arbitrary+      y2 :: BoolN "y" <- arbitrary++      let f2 (_ :: Label "x") x (_ :: Label "y") y () = f1 x y+          f = f2 .*. recToKW [pun| x y |]++      return $ conjoin+        [ kw f lx x2 ly y2 () `eq` f1 x2 y2,+          kw f ly y2 lx x2 () `eq` f1 x2 y2,+          kw f ly y2 () `eq` f1 x y2,+          kw f lx x2 () `eq` f1 x2 y,+          kw f () `eq` f1 x y ]++    -- alternatively, a function taking a record is pretty much+    -- a keyword argument. Error messages for missing keywords+    -- are a bit worse (blame hRearrange')+    it "f2Alt" $ property $ do+      (f1 :: BoolN "x" -> BoolN "y" -> BoolN "z") <- arbitrary+      x :: BoolN "x" <- arbitrary+      x2 :: BoolN "x" <- arbitrary+      y :: BoolN "y" <- arbitrary+      y2 :: BoolN "y" <- arbitrary++      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,+          f2 (lx .=. x2 .*. emptyRecord) `eq` f1 x2 y,+          f2 (ly .=. y2 .*. emptyRecord) `eq` f1 x y2,+          f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord) `eq` f1 x2 y2,+          f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2+        ]+
+ examples/Properties/LengthDependent.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+-- NOTE:+--+-- To be able to compile with ghc-7.6 functions like foo are sometimes+-- called+--+-- $(varE 'foo) because this prevents ghc-7.6 from failing to typecheck+-- the expression (which fails because the number of elements in the+-- supplied HList isn't known until Properties.LengthDependentSplice)+module Properties.LengthDependent where++#if MIN_VERSION_base(4,9,0)+import qualified Data.Kind as DK+#endif++import Data.HList.HSort (hMSortBy)+import Data.HList.Variant (eqVariant)+import Data.HList.Record (hZipRecord2)+import Data.HList.HList (hAppend')+import Data.HList.CommonMain+++#if MIN_VERSION_template_haskell(2,17,0)+import Language.Haskell.TH.Lib.Internal hiding (doE)+import Language.Haskell.TH (Name, mkName, doE)+#else+import Language.Haskell.TH+#endif++import Test.QuickCheck+import Properties.Common+import Test.Hspec+import Control.Lens+import Data.List (sort,permutations)+import Data.Monoid++hlN :: Int -> ExpQ+hlN n = [| \proxy -> hSequence+              $ $(varE 'hReplicate) $(hNatE n)+                    (arbitrary `asTypeOf` return proxy) |]++-- > $(rKN id n) (undefined :: t) :: Arbitrary t => Gen (HList [Record t1, Record t2, ... ])+--+-- where+--    t1 ~ '[Tagged 1 t, Tagged 2 t, Tagged 3 t, ... , Tagged n t]+--    t2 ~ '[Tagged 2 t, Tagged 1 t, Tagged 3 t, ... , Tagged n t]+--    tN ~ nth permutation of t1+rKN :: (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n+    -> Int+    -> ExpQ+rKN = rKN' (litT . numTyLit)+++rKN' ::+    (Integer -> TypeQ) -- ^ make the label+    -> (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n+    -> Int+    -> ExpQ+rKN' mkLab takeK n = [| \proxy -> do+        $(recs [| arbitrary `asTypeOf` return proxy |])+            `asTypeOf` return $sig+         |]+    where sig = [| undefined |] `sigE` quantify [t| HList $(hListT rss) |]+++          ti :: Int -> Name+          ti i = mkName ("t" ++ show i)++          recs gen = doE $+               [ bindS (varP (ti i)) gen   | i <- [1 .. n] ] +++               [ noBindS+                  [| return $ $(hListE+                      [ [| unlabeled # $(hListE (map (varE . ti) is)) |]+                        | is <- takeK $ permutations [1 .. n] ])+                   |]+                ]++          myForallT :: [Name] -> TypeQ -> TypeQ+#if MIN_VERSION_template_haskell(2,17,0)+          myForallT ns = forallT [ plainInvisTV n inferredSpec | n <- ns ] (cxt [])+#else+          myForallT ns = forallT (map plainTV ns) (cxt [])+#endif+          quantify :: TypeQ -> TypeQ+          quantify = myForallT [ mkName ("x" ++ show i) | i <- [1 .. n]]+++          rss :: [TypeQ]+          rss = takeK $+#if MIN_VERSION_base(4,9,0)+                [ [t| (Record :: [DK.Type] -> DK.Type) $(hListT (map taggedN ns)) |]+#else+                [ [t| (Record :: [*] -> *) $(hListT (map taggedN ns)) |]+#endif+                   | ns <- permutations [1 .. fromIntegral n] ]++          -- taggedN 1 == [t| Tagged 1 x1 |]+          taggedN :: Integer -> TypeQ+          taggedN i = [t| Tagged $(mkLab i) $(varT (mkName ("x"++show i))) |]++-- | > $(rN n) :: a -> Record [Tagged 1 a, Tagged 2 a, ... Tagged n a]+rN n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN (take 1) n) proxy |]+++-- | > $(rNstr n) :: a -> Record [Tagged "1" a, Tagged "2" a, ... Tagged n a]+rNstr n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN' (litT . strTyLit . show) (take 1) n) proxy |]++vN :: Int -> ExpQ+vN n = [| \proxy -> do+       let toV :: Gen (Record a) -> Variant a+           toV = undefined+       v <- arbitrary+       return (v `asTypeOf` toV ($(rN n) proxy))+  |]++-- specs for 1 HList of length >= 1+hl1 n1 = [| do+  let -- | generate a HList of length nMax containing elements+      -- selected from there+      genHL proxy = $(hlN n1) proxy++  it "hConcat/hAppend" $+      property $ do+        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" $+      property $ do+        x <- genHL True+        return $ conjoin+          [hPartitionEq (Proxy :: Proxy ConstTrue) (Proxy :: Proxy ()) x `eq` (x, HNil),+           hPartitionEq (Proxy :: Proxy ConstFalse) (Proxy :: Proxy ()) x `eq` (HNil, x)]+++  it "listAsHList/hList2List" $ do+      property $ do+        x <- genHL True+        return $ conjoin [+            review listAsHList x `eq` hList2List x,+            review listAsHList' x `eq` hList2List x]++  it "read/show" $+      property $ do+        xs <- genHL True+        return $ read (show xs) == xs++  it "hLength/hReplicate" $+      property $ do+        xs <- genHL True+        return $ hNat2Integral (hLength xs) == hNat2Integral $(hNatE n1)++  it "hInits last id" $+      property $ do+        xs <- genHL True+        return $ $(varE 'hLast) (hInits xs) == xs++  it "hInits head empty" $+      property $ do+        xs <- genHL True+        return $ hHead (hInits xs) == HNil++  it "hTails head id" $+      property $ do+        xs <- genHL True+        return $ hHead (hTails xs) == xs++  it "hTails last empty" $+      property $ do+        xs <- genHL True+        return $ $(varE 'hLast) (hTails xs) == HNil++  it "hScanr equals scanr" $+      property $ do+        f <- arbitrary+        a <- arbitrary+        hl <- genHL True+        return $ hList2List (hScanr (BinF f) a hl)+                == scanr f a (hList2List hl)++  it "hFoldr equals foldr" $+      property $ do+        f <- arbitrary+        a <- arbitrary+        hl <- genHL True+        return $ hFoldr (BinF f) a hl == foldr f a (hList2List hl)++  it "hFoldr1 equals foldr1" $+      property $ do+        f <- arbitrary+        hl <- genHL True+        return $ hFoldr1 (BinF f) hl == foldr1 f (hList2List hl)++  it "hFoldl equals foldl" $+      property $ do+        f <- arbitrary+        a <- arbitrary+        hl <- genHL True+        return $ hFoldl (BinF f) a hl == foldl f a (hList2List hl)++  it "hSplitAt" $+      property $ do+        hl <- genHL True+        let n = hLength hl+            l = hList2List hl+        -- hList2List doesn't like empty lists, and hMapOut id needs+        -- annotations, so the following cases are easier to construct+        -- than a direct comparison with splitAt+        return $ conjoin+          [ case hSplitAt hZero hl of+              (hNil, hl') -> (hNil `eq` HNil) .&&. (hl' `eq` hl),+            case $(varE 'hSplitAt) n hl of+              (hl', hNil) -> (hNil `eq` HNil) .&&. (hl' `eq` hl),++            $(varE 'hMap) (HSplitAtAppend hl) ($(varE 'hIterate) (hSucc n) HSuccF hZero) `eq` $(varE 'hReplicate) (hSucc n) hl ,+            map (\n -> uncurry (++) $ splitAt n l) [0 .. length l]      === replicate (length l+1) l+              -- the equivalent list-version+           ]++  it "hAppend empty is identity" $+      property $ do+        x <- genHL (BoolN True :: BoolN "x")+        return $ all (== x) [$(varE 'hAppend) HNil x, $(varE 'hAppend) x HNil]++  it "hReverse involution" $ do+      property $ do+        x <- genHL True+        return $ x == $(varE 'hReverse) (hReverse x)++  it "hReverse does nothing for ()" $+      let xs = $(varE 'hReplicate) $(hNatE n1) ()+      in xs `shouldBe` $(varE 'hReverse) xs++  it "hInit == tail on reverse" $+      property $ do+        let hInitReference xs = hReverse (hTail (hReverse xs))+        hl <- genHL True+        return $ $(varE 'hInit) hl `eq` $(varE 'hInitReference) hl++  it "hList2List/list2HList" $ property $ do+      x <- genHL True+      return $ list2HList (hList2List x) === Just x++  it "hMap equals map" $ property $ do+      f  <- arbitrary+      hl <- genHL True+      return $ hList2List (hMap f hl) `eq` map (f :: Bool -> BoolN "f") (hList2List hl)++  it "hZip" $ property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "y")+      return $ hList2List (hZip x y) `eq` hList2List x `zip` hList2List y++  it "hZipRecord" $ property $ do+      x <- $(rN n1) (BoolN True :: BoolN "x")+      y <- $(rN n1) (BoolN True :: BoolN "y")+      let r1 = hZip x y ^. unlabeled & hList2List+          r2 = hZipRecord2 x y ^. unlabeled & hList2List+          r_ = hList2List (x ^. unlabeled) `zip` hList2List (y ^. unlabeled)++      return $ conjoin [+          r1 `eq` r_,+          r2 `eq` r_,+          hUnzip (hZip x y) `eq` (x,y) ]++  it "hZip/hUnZip" $ property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "y")+      return $ hUnzip (hZip x y) == (x,y)++  it "hUnzip/hZip" $ property $ do+      xy <- genHL (BoolN True :: BoolN "x", BoolN True :: BoolN "y")+      let (x,y) = hUnzip xy+      return $ xy `eq` hZip x y++  it "hUnzip2/hZip2" $ property $ do+      xy <- genHL (BoolN True :: BoolN "x", BoolN True :: BoolN "y")+      let (x,y) = hUnzip2 xy+      return $ xy `eq` hZip2 x y++  -- XXX doesn't work with ghc-7.10.1+  -- (should be fixed for 7.10.2)+  it "hZip/hZip2" $ property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "y")+      return $ hZip x y `eq` hZip2 x y++  -- lots of duplication, not sure if it's worth factoring out+  it "HList monoid unit" $+    property $ do+      x <- genHL (BoolN True :: BoolN "x")+      return $ conjoin+        [ x === (x `mappend` mempty),+          x === (mempty `mappend` x) ]+  it "Record monoid unit" $+    property $ do+      x <- $(rN n1) (BoolN True :: BoolN "x")+      return $ conjoin+        [ x === (x `mappend` mempty),+          x === (mempty `mappend` x) ]+  it "Variant monoid unit" $+    property $ do+      x <- $(rN n1) (BoolN True :: BoolN "x")+      return $ conjoin+        [ x === (x `mappend` mempty),+          x === (mempty `mappend` x) ]++  -- lots of duplication, not sure if it's worth factoring out+  it "HList monoid assoc" $+    property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "x")+      z <- genHL (BoolN True :: BoolN "x")+      return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z))+  it "Record monoid assoc" $ property $ do+    x <- $(rN n1) (BoolN True :: BoolN "x")+    y <- $(rN n1) (BoolN True :: BoolN "x")+    z <- $(rN n1) (BoolN True :: BoolN "x")+    return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z))+  it "Variant monoid assoc" $ property $ do+    x <- $(vN n1) (BoolN True :: BoolN "x")+    y <- $(vN n1) (BoolN True :: BoolN "x")+    z <- $(vN n1) (BoolN True :: BoolN "x")+    return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z))++  it "Variant == /eqVariant" $ property $ do+    x <- $(vN n1) (BoolN True :: BoolN "x")+    y <- $(vN n1) (BoolN True :: BoolN "x")+    return $ conjoin [ eqVariant x y == (x == y),+                       (x == y) == (y == x) ]++  it "Variant ord" $ property $ do+    x <- $(vN n1) (BoolN True :: BoolN "x")+    y <- $(vN n1) (BoolN True :: BoolN "x")+    z <- $(vN n1) (BoolN True :: BoolN "x")+    let xyz = [x,y,z]+        s:ss = map sort (permutations xyz)+    return $ all (s ==) ss++#if __GLASGOW_HASKELL__ > 707 && __GLASGOW_HASKELL__ < 901+  -- ghc-7.6 has no ordering for Nat (only for HNat)+  it "hSort (the labels)" $ property $ do+    x <- $(rN n1) True+    let rx = x & from hListRecord %~ hReverse+    -- rN generates a record that has labels in ascending order already+    return $ conjoin [+         x `eq` (x  & from hListRecord %~ hSort),+         x `eq` (rx & from hListRecord %~ hSort),+         x `eq` (x  & from hListRecord %~ hMSortBy (Proxy :: Proxy HLeFn)),+         x `eq` (rx & from hListRecord %~ hMSortBy (Proxy :: Proxy HLeFn))+         ]++  -- restrict to lists of length 4 (since then the number of permutations+  -- is a manageable 24 not 120)+  it "hSort permutations" $ property $ do+    xs <- $(rKN id (min 4 n1)) True+    return $ all (== hHead xs) (hMapOut HSortF xs)++#endif++  it "hRenameLabel" $ property $ do+    r <- $(rN n1) True+    return $ conjoin+        $(listE [ [| hRenameLabel $ln lx r .!. lx === r .!. $ln |]+              | i <- [1 .. n1],+                let ln = [| Label :: Label $(litT (numTyLit (fromIntegral i))) |]+            ])+#if __GLASGOW_HASKELL__ < 901+  it "rearranged / hMapR" $ property $ do+    r <- $(rN n1) True+    let revR = r & from hListRecord %~ hReverse+        asT :: x -> As x+        asT _ = id+    -- hMap works on the reversed list+    return $ hMapR not r === (r & rearranged' . asT revR . unlabeled %~ hMap not)+#endif+++  it "hOccurs" $ property $ do+    w <- arbitrary :: Gen (BoolN "w")+    x <- genHL (BoolN True :: BoolN "x")+    y <- genHL (BoolN True :: BoolN "y")+    z <- genHL (BoolN True :: BoolN "z")+    let xyz = hConcat (hBuild x y z)+        hxyz = hEnd (hBuild (hHead x) (hHead y) (hHead z))++        -- -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+      [ 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)+       ]++ |]++hl2 n1 n2 = [| do+  it "splitVariant" $ property $ do+    x <- $(vN (n1 + n2)) True+    let testV :: forall n x yin yout.+               (Eq (Variant x),+                SplitVariant x yin yout,+                HSplitAt n x yin yout,+                ExtendsVariant yin x,+                ExtendsVariant yout x) =>+                Proxy n -> Variant x -> Bool+        testV n v = case $(varE 'splitVariant) v of+                      Left a -> extendsVariant (a :: Variant yin) == v+                      Right a -> extendsVariant (a :: Variant yout) == v+    return $ $(varE 'testV) $(hNatE n1) x+++  it "hAppend equals ++" $+    property $ do+      x <- $(hlN n1) True+      y <- $(hlN n2) True+      return $ hList2List (hAppend x y) === hList2List x ++ hList2List y++  it "hTranspose involution" $ property $ do+    x <- return (error "hTranspose involution") `asTypeOf` $(hlN n1) True+    xx <- $(hlN n2) x+    return $ $(varE 'hTranspose) ($(varE 'hTranspose) xx) === xx++  it "leftUnion / unionSR" $+    property $ do+      x <- $(rN n1) True+      y <- $(rN n2) True+      let asL r = r ^. unlabeled . to hList2List+          asLs (r1,r2) = (asL r1, asL r2)+          merge xs ys = xs ++ drop (length xs) ys+          mergeSym xs ys = (merge xs ys, merge ys xs)+          eqSorted (a,b) (c,d) = sort a === sort c .&&. sort b === sort d+      return $ conjoin [+        asL (x .<++. y) === asL x `merge` asL y,+        ($(varE '(.<++.)) x x) === x,+        ($(varE '(.<++.)) y y) === y,+        asLs (unionSR x y) `eqSorted` mergeSym (asL x) (asL y),+        (x `unionSR` x) === (x,x),+        (y `unionSR` y) === (y,y)]++    |]++hl3 n1 n2 n3 = [| do+  it "hAppend/hAppendList assoc" $+    property $ do+      x <- $(hlN n1) (BoolN True :: BoolN "x")+      y <- $(hlN n2) (BoolN True :: BoolN "y")+      z <- $(hlN n3) (BoolN True :: BoolN "z")+      return $ conjoin+#if __GLASGOW_HASKELL__ < 707+        [ $([| (x `hAppend` y) `hAppend` z |]) === $([| x `hAppend` (y `hAppend` z) |]),+          $([| (x `hAppendList` y) `hAppendList` z|]) === $([| x `hAppendList` (y `hAppendList` z)|])+        ]+#else+        [ ((x `hAppend` y) `hAppend` z) === (x `hAppend` (y `hAppend` z)),+          ((x `hAppendList` y) `hAppendList` z) === (x `hAppendList` (y `hAppendList` z))+        ]+#endif+  |]
+ examples/Properties/LengthDependentSplice.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# OPTIONS_GHC -freduction-depth=100 #-}+#else+{-# OPTIONS_GHC -fcontext-stack=100 #-}+#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MonoLocalBinds #-} -- maybe it isn't necessary for everything?+module Properties.LengthDependentSplice where+import Properties.LengthDependent+import Language.Haskell.TH+import Test.Hspec++hl1_2_3 :: Spec+hl1_2_3 = $(doE $+        [ noBindS+               [| describe $(stringE (show n)) $(hl1 n) |]+            | n <- [1 .. 5]]+    ++ [ noBindS [| describe $(stringE (show (n1,n2))) $(hl2 n1 n2) |]+      | 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 .. 1],+        not $ all (==0) [n1,n2,n3] ]+  )
+ examples/Properties/LengthIndependent.hs view
@@ -0,0 +1,688 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# 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+import Control.Monad++import Data.Generics++makeLabels3 "lengthindependent" (words "lx_ ly_")+++-- | tests for a fixed length+hl0 = describe "0 -- length independent"  $ do+  hTuples++  it "listAsHList" $ property $ do+    (f :: Bool -> Bool) <- arbitrary+    let bools = [True,False]+        mapF (a `HCons` b `HCons` HNil) = f a `HCons` f b `HCons` HNil+        len3 = id :: As (HList '[a,b,c])+        len2 = id :: As (HList [a,b])+        len1 = id :: As (HList '[a])+    return $ conjoin+      [ (bools & listAsHList %~ mapF) `eq` map f bools,+        (bools & listAsHList' . len2 %~ hMap f ) `eq` map f bools,+        (bools & listAsHList' . len3 %~ hMap f ) `eq` ([] :: [Bool]),+        (bools & listAsHList' . len1 %~ hMap f ) `eq` ([] :: [Bool])]++  it "read0" $ read "H[]" `shouldBe` HNil++  it "Fun" $ property $ do+    let plusF = Fun (+1) :: Fun Num '()+    x :: Int <- arbitrary+    y :: Double <- arbitrary+    return $ hMap plusF (hBuild x y) === hEnd (hBuild (x+1) (y+1))++  it "Fun 2" $ property $ do+    let showSuccF = Fun (show . (+1)) :: Fun [Num,Show] String+    x :: Int <- arbitrary+    y :: Double <- arbitrary+    return $ hMapOut showSuccF (hBuild x y) === [ show (x+1), show (y+1)]++  it "Fun'" $ property $ do+    x :: Bool <- arbitrary+    return $ applyAB (Fun' read :: Fun' Read String) (show x) === x++  it "HComp" $ property $ do+    let f = Fun (+1) :: Fun Num '()+        g = Fun show :: Fun Show String+        gof = g `HComp` f++    x :: Int <- arbitrary+    y :: Double <- arbitrary++    let ref = [show (x+1), show (y+1)]++    return $ conjoin [+        hMapOut gof (hBuild x y) `eq` ref,+        hMapOut g (hMap f (hBuild x y)) `eq` ref ]++  it "toLabel 1" $+    case hCast (toLabel (hLens' lx)) of+      l -> True `const` (l `asTypeOf` Just lx)++  it "toLabel 2" $ case hCast (toLabel lx) of+      l -> True `const` (l `asTypeOf` Just lx)++  it "HCast is ==" $ property $ do+    x :: BoolN "x" <- arbitrary+    x' :: BoolN "x" <- arbitrary+    return $ (x == x') ==> (x `eq` x')++  it "HCast neq" $ property $ do+    x :: BoolN "x" <- arbitrary+    y :: BoolN "y" <- arbitrary+    return (expectFailure $ x `eq` y)++  let mkXYvariant = do+        (x :: Bool) <- arbitrary+        (my :: Maybe Bool) <- arbitrary+        return $ (ly .=. my .*. mkVariant1 lx x,+                  my)++  it "variant lookup/extend" $ do+    property $ do+      (v, my) <- mkXYvariant+      return $ conjoin [+          v .!. ly == my,+          v ^? hLens' ly == my,+          v ^? hPrism ly == my ]++  it "variant update" $ property $ do+    x :: Maybe (BoolN "x") <- arbitrary+    x' :: BoolN "x'" <- arbitrary+    y :: BoolN "y" <- arbitrary+    let v = lx .=. x .*. mkVariant1 ly y+        v' | isJust x = lx .=. Just x' .*. mkVariant1 ly y+           | otherwise = lx .=. Nothing .*. mkVariant1 ly y+    return $ conjoin [+        hUpdateAtLabel lx x' v === v',+        (v & hLens' lx .~ x') === v',+        (v & hPrism lx .~ x') === v']+++  it "unvariant" $ do+    property $ do+      (v, _) <- mkXYvariant+      return $ unvariant v == fromJust (msum [v .!. ly, v .!. lx])++  it "unvarianted" $ property $ do+    x :: Maybe Bool <- arbitrary+    y :: Bool <- arbitrary+    let v = lx .=. x .*. mkVariant1 ly y+        vUnitExpected = lx .=. (() <$ x) .*. mkVariant1 ly ()+        vUnit = v & unvarianted .~ ()+        vNot = lx .=. (not <$> x) .*. mkVariant1 ly (not y)+    return $ conjoin [+        v ^. unvarianted === fromMaybe y x,+        (v & unvarianted %~ not) === vNot,+        vUnit === vUnitExpected,+        vUnit ^. unvarianted === ()  ]++  it "HMapOutV" $ do+    property $ do+      (v, _) <- mkXYvariant+      return $ hMapOutV not v `eq` not (fromJust (msum [v .!. ly, v .!. lx]))++  it "zipVR" $ property $ do+    (f :: BoolN "x" -> BoolN "x'",+     g :: BoolN "y" -> BoolN "y'",+     b,x,y) <- arbitrary+    let p = lx .*. ly .*. emptyProxy+        v  | b = mkVariant lx x Proxy `asLabelsOf` p+           | otherwise = mkVariant ly y Proxy+        v' | b = mkVariant lx (f x) Proxy `asLabelsOf` p+           | otherwise = mkVariant ly (g y) Proxy++        fun = lx .=. f .*. ly .=. g .*. emptyRecord++    return $ zipVR fun v `eq` v'++  it "zipVariant" $ property $ do+    x1 :: Maybe (BoolN "x1") <- arbitrary+    x2 :: Maybe (BoolN "x2") <- arbitrary+    y1 :: BoolN "y1" <- arbitrary+    y2 :: BoolN "y2" <- arbitrary++    let v1 = lx .=. x1 .*. mkVariant1 ly y1+        v2 = lx .=. x2 .*. mkVariant1 ly y2++        vrT = Proxy :: Proxy '[ Tagged "x" (BoolN "x1", BoolN "x2"),+                                Tagged "y" (BoolN "y1", BoolN "y2") ]+        vr = case (x1,x2) of+               (Just a, Just b) -> Just $ mkVariant lx (a,b) vrT+               (Nothing, Nothing) -> Just $ mkVariant ly (y1,y2) vrT+               _ -> Nothing++    return $ zipVariant v1 v2 `eq` vr++  it "variant Eq" $ property $ do+    x1 :: Maybe (BoolN "x") <- arbitrary+    x2 :: Maybe (BoolN "x") <- arbitrary+    y1 :: BoolN "y" <- arbitrary+    y2 :: BoolN "y" <- arbitrary++    let v1 = lx .=. x1 .*. mkVariant1 ly y1+        v2 = lx .=. x2 .*. mkVariant1 ly y2+    return $ (v1 == v2) === (x1 == x2 && (isJust x1 || y1 == y2))+++  it "projectVariant" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    z <- arbitrary++    let vFull :: Variant [Tagged "a" (BoolN "a"),+                          Tagged "b" (BoolN "b"),+                          Tagged "c" (BoolN "c"),+                          Tagged "z" (BoolN "z")]+        vFull = a .*. b .*. c .*. mkVariant1 Label z++        isN x = isNothing (untag x)+        vZJ :: Variant '[Tagged "z" (BoolN "z")]+        vZJ = mkVariant1 Label z++        vZ | isN a, isN b, isN c = Just vZJ+           | otherwise = Nothing++    return $ conjoin [+       vFull ^? projected === vZ,+       -- XXX maybe projected can be made to work instead of projected'+       ((projected' # vZJ) `asTypeOf` vFull) ^? projected === Just vZJ+       ]++  it "variant/tic extend" $ do+    property $ do+      x :: BoolN "x" <- arbitrary+      my :: Maybe (BoolN "y") <- arbitrary+      let v = ly .=. my .*. mkVariant1 lx x+          tic1 = my .*. mkTIC1 x+      return $ conjoin+        [ -- v == tic1 ^. from typeIndexed,+          v^. typeIndexed == tic1+          ]++++  it "variant/typeIndexed" $ do+    property $ do+      x :: BoolN "x" <- arbitrary+      y :: Maybe (BoolN "y") <- arbitrary+      let v = ly .=. y .*. mkVariant1 lx x+      let tic = v ^. typeIndexed+      return $ conjoin+        [ v .!. ly === hOccurs tic,+          v .!. ly === tic ^? ticPrism,+          v .!. ly `eq` tic .!. (Label :: Label (BoolN "y")),++          v .!. lx === hOccurs tic,+          v .!. lx === tic ^? ticPrism,+          v .!. lx `eq` tic .!. (Label :: Label (BoolN "x"))+        ]++  it "Record/typeIndexed" $ do+    property $ do+      x :: BoolN "x" <- arbitrary+      y :: BoolN "y" <- arbitrary+      let r = ly .=. y .*. lx .=. x .*. emptyRecord+          tip = r ^. typeIndexed++          asX :: As (BoolN "x")+          asX = id+          asY :: As (BoolN "y")+          asY = id++      return $ conjoin+        [ r .!. lx === hOccurs tip,+          r .!. lx === tip ^. tipyLens,+          r .!. lx `eq` tip .!. (Label :: Label (BoolN "x")),++          -- two ways to apply 'not' to the 'x' field+          (r & hLens lx . boolN %~ not) `eq`+              (r & typeIndexed %~ ttip (asX . boolN %~ not)),++          -- and repeat everything for the other field+          r .!. ly === hOccurs tip,+          r .!. ly === tip ^. tipyLens,+          r .!. ly `eq` tip .!. (Label :: Label (BoolN "y")),+          (r & hLens ly . boolN %~ not) `eq`+              (r & typeIndexed %~ ttip (asY . boolN %~ not))+        ]++  -- other operations union, projection etc.+  it "Record lookup mixing labels" $ do+    property $ do+      v1 :: BoolN "v1" <- arbitrary+      v2 :: BoolN "v2" <- arbitrary+      v3 :: BoolN "v3" <- arbitrary+      let l1 = Label :: Label ()+          l2 = Label :: Label 2+          l3 = Label :: Label "3"+          p = Proxy :: Proxy '[Label (), Label 2 , Label "3"]++          p1 = consl1 $ l2 .*. l3 .*. emptyProxy++          -- HExtend doesn't support Label5+          consl1 :: Proxy x -> Proxy (Label () ': x)+          consl1 _ = Proxy++          r = hEndR (hBuild v1 v2 v3) `asLabelsOf` p+      return $ conjoin+        [ r.!.l1 `eq` v1,+          r.!.l2 `eq` v2,+          p1 `eq` p ]++  it "Record hLookupByLabelM" $ property $ do+    v :: BoolN "v" <- arbitrary+    w :: BoolN "v" <- arbitrary+    let r = [pun| v |]+    return $ conjoin+      [ hLookupByLabelM (Label :: Label "v") r w `eq` v,+        hLookupByLabelM (Label :: Label "w") r w `eq` w ]++  it "HOccurs HList" $ do+    property $ do+      x <- arbitrary+      return $ hOccurs (hEnd (hBuild x)) == (x :: Bool)++  it "HOccurs TIP" $ do+    property $ do+      x <- arbitrary+      return $ hOccurs (hEnd (hBuild x) ^. from tipHList) == (x :: Bool)++  it "HOccurs TIP inference" $+    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+      (a :: BoolN "a") <- arbitrary+      (b :: BoolN "b") <- arbitrary+      (c :: BoolN "c") <- arbitrary+      let tp = a .*. b .*. c .*. emptyTIP+      return $ hOccurs (ttip f tp) == (f a b c :: BoolN "a")++  it "ttipM 3" $ do+    property $ do+      f <- arbitrary+      (a :: BoolN "a") <- arbitrary+      (b :: BoolN "b") <- arbitrary+      (c :: BoolN "c") <- arbitrary+      let tp = a .*. b .*. c .*. emptyTIP+      return $ hOccurs (runIdentity (ttipM f tp)) == (runIdentity (f a b c) :: BoolN "a")++  it "Show/Read instances" $ do+    show (hEnd (hBuild 1 2 3)) `shouldBe` "H[1,2,3]"++    let r = lx .=. 'x' .*. ly .=. "y" .*. emptyRecord+    show r `shouldBe` "Record{x='x',y=\"y\"}"+    read (show r) `shouldBe` r++    show (r ^. unlabeled . from tipHList) `shouldBe` "TIPH['x',\"y\"]"++    v <- return $ map ($ r) [mkVariant lx 'a', mkVariant ly "ly"]++    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+      a :: Maybe Bool <- arbitrary+      b :: Bool <- arbitrary+      let h = hEnd $ hBuild a b+          v = lx_ .=. a .*. mkVariant1 ly_ b+          r = (unlabeled # h) `asLabelsOf` pLabel3++          -- ghc-7.8 can't use pLabel5 (due to a lack of Typeable "x")+          pLabel3 = lx_ .*. ly_ .*. emptyProxy+          pLabel5 = lx .*. ly .*. emptyProxy -- Proxy :: Proxy ["x","y"]+      return $ conjoin+        [ gread (gshow h) === [(h, "")],+          gread (gshow v) === [(v, "")],+          gread (gshow r) === [(r, "")] ]++  it "Enum" $ do+    show [ mkVariant lx False (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool]) .. maxBound ]+      `shouldBe` "[V{x=False},V{x=True},V{y=False},V{y=True}]"++  it "minBound" $ do+    mkVariant lx False (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool])+      `shouldBe` minBound++++  it "projected" $ do+    property $ do+      (f :: Bool -> Bool -> Bool) <- arbitrary+      x :: Bool <- arbitrary+      y :: Bool <- arbitrary+      let r = lx .=. x .*. ly .=. y .*. lz .=. () .*. emptyRecord+          g1 [pun| (x y) |] = case f x y of z -> [pun| z |]+          g2 [pun| (y x) |] = case f x y of z -> [pun| z |]++          rExpect = lx .=. x .*. ly .=. y .*. lz .=. f x y .*. emptyRecord++      containX :: Bool <- arbitrary+      let+          v p | containX = mkVariant lx x p+            | otherwise = mkVariant ly y Proxy+++          v1 = v (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool, Tagged "z" Char])+          v2 = v (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool])++          v1not = v1 & sameLength . sameLabels . projected %~ hMapV Just . (`asLabelsOf` labelsOf v2)+++      return $ conjoin+        [ (r & sameLabels . projected %~ g1) `eq` rExpect+        , (r & sameLabels . projected %~ g2) `eq` rExpect+        , (v1 ^? projected) === Just v2+        , review projected v2 === v1+          ]+++  it "unboxed" $ do+    property $ do+      (x :: Bool) <- arbitrary+      (y :: Bool) <- arbitrary+      (z :: Bool) <- arbitrary+      let r = [pun| x y z |]+          ru = r ^. unboxed+      return $ conjoin+       [ ru .!. lx === x,+         ru .!. ly === y,+         ru .!. lz === z,+         hUpdateMany r ru === ru,+         hMapRU not ru ^. from unboxed . unlabeled . re listAsHList'+                === map not [x,y,z],+         r === ru ^. from unboxed ]++  it "unboxedS" $ do+    property $ do+      (x :: Bool) <- arbitrary+      (y :: Int) <- arbitrary+      (z :: Int) <- arbitrary+      let r = [pun| x y z |]+          ru = r ^. unboxedS+      return $ conjoin+        [ ru .!. lx === x,+          ru .!. ly === y,+          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+    mempty `shouldBe` emptyTIP+    mempty `shouldBe` mkVariant1 lx ()+    mempty `shouldBe` (mkVariant ly () (Proxy :: Proxy '[Tagged "x" [Int], Tagged "y" ()]))+++  it "identity: rearranged relabeled unlabeled" $ do+    let r = lx .=. True .*.+            ly .=. () .*. emptyRecord+    (r ^. rearranged) `shouldBe` r+    (r ^. relabeled) `shouldBe` r+    (r & unlabeled %~ id) `shouldBe` r++  it "rearranged" $ do+    let r = lx .=. True .*.+            ly .=. () .*. emptyRecord+    let r2 = ly .=. () .*.+            lx .=. True .*. emptyRecord+    (r ^. rearranged) `shouldBe` r2++  it "relabeled" $ do+    let r = lx .=. True .*.+            ly .=. () .*. emptyRecord+    let r2 = ly .=. True .*.+            lx .=. () .*. emptyRecord+    (r ^. relabeled) `shouldBe` r2++  it "hMaybied" $ property $ do+    mx :: Maybe Bool <- arbitrary+    my :: Maybe Bool <- arbitrary+    let r = lx .=. mx .*. ly .=. my .*. emptyRecord+        vT = Proxy :: Proxy [Tagged "x" Bool, Tagged "y" Bool]+        (val, v)  = case (mx,my) of+          (Just x, Nothing) -> (Just x, Just (mkVariant lx x vT))+          (Nothing, Just y) -> (Just y, Just (mkVariant ly y vT))+          _ -> (Nothing, Nothing)++    return $ conjoin [+      (r^?hMaybied <&> unvariant) `eq` val,+      isJust v ==> ( hMaybied' # fromJust v === r ) ]++  it "hMaybied 2" $ property $ do+    x :: BoolN "x"  <- arbitrary+    my :: Maybe (BoolN "y") <- arbitrary+    let v = ly .=. my .*. mkVariant1 lx x+        r = ly .=. my .*. lx .=. Just x .*. emptyRecord++    return $ (r ^? hMaybied) `eq` do+      guard $ isNothing my+      Just v++  it "hMaybied update" $ property $ do+    (f :: BoolN "x" -> BoolN "w",y :: BoolN "y") <- arbitrary+    let x  = lx .=. (Nothing :: Maybe (BoolN "x")) .*. ly .=. Just y .*. emptyRecord+        x' = lx .=. (Nothing :: Maybe (BoolN "w")) .*. ly .=. Just y .*. emptyRecord++    return $ (x & sameLength . hMaybied . hPrism lx %~ f) === x'++  it "hPrism" $ property $ do+    x :: Bool <- arbitrary+    my :: Maybe (Maybe ()) <- arbitrary+    let v  = ly .=. my .*. mkVariant1 lx x+        v' = ly .=. my .*. mkVariant1 lx (not x)++        tic = my .*. mkTIC1 x+        tic' = my .*. mkTIC1 (not x)++    return $ conjoin+      [ v' `eq` (v & hPrism lx %~ not),+        tic' `eq` (tic & hLens' Label %~ not),+        tic' `eq` (tic & ticPrism %~ not)+      ]++  it "hDeleteAtLabel" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    let r  = lx .=. vx .*. ly .=. vy .*. lz .=. vz .*. emptyRecord+        ry =               ly .=. vy .*. lz .=. vz .*. emptyRecord+        rx = lx .=. vx .*.               lz .=. vz .*. emptyRecord++    return $ conjoin [+      (r .-. lx) `eq` ry,+      (r .-. ly) `eq` rx ]++  it "hBuild/hEndR" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    let r = hEndR (hBuild vx vy vz) `asLabelsOf` (lx .*. ly .*. lz .*. emptyProxy)+        r_ = lx .=. vx .*. ly .=. vy .*. lz .=. vz .*. emptyRecord++    return $ r `eq` r_+++  it "hUncurry" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    return $ conjoin+      [ hUncurry (,,) (hBuild vx vy vz) `eq` (vx,vy,vz),+        hCurry (hUncurry (,,)) vx vy vz `eq` (vx,vy,vz),+#if __GLASGOW_HASKELL__ > 948+        hCurry (hUncurry id) vx `eq` vx,+#endif+        hCurry ( \(a `HCons` b `HCons` HNil) -> (b,a)) vx vy `eq` (vy,vx)+      ]++  it "hCompose" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    return $ conjoin+      [ hCompose (,) (,) vx vy vz `eq` ((vx,vy), vz)+        , hCompose id (,) vx vy `eq` (vx,vy),+#if __GLASGOW_HASKELL__ > 948+        , hCompose (,) id vx vy `eq` (vx,vy)+#endif+        ]+++hTuples = do+  it "HTuple0" $ do+    HNil ^. hTuple `shouldBe` ()+    (HNil & hTuple %~ id) `shouldBe` HNil++  it "HTuple2" $ property $ do+    a <- arbitrary+    b <- arbitrary+    let ab = (a :: BoolN "a",b :: BoolN "b")+    return $ hBuild a b ==  ab ^. from hTuple+        && hBuild a b ^. hTuple == ab++  it "HTuple3" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c")+    return $ hBuild a b c ==  abc ^. from hTuple+      && hBuild a b c ^. hTuple == abc++  it "HTuple4" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    d <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c",+               d :: BoolN "d")+    return $ hBuild a b c d ==  abc ^. from hTuple+      && hBuild a b c d ^. hTuple == abc++  it "HTuple5" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    d <- arbitrary+    e <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c",+               d :: BoolN "d", e :: BoolN "e")+    return $ hBuild a b c d e ==  abc ^. from hTuple+      && hBuild a b c d e ^. hTuple == abc++  it "HTuple6" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    d <- arbitrary+    e <- arbitrary+    f <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c",+               d :: BoolN "d", e :: BoolN "e", f :: BoolN "f")+    return $ hBuild a b c d e f ==  abc ^. from hTuple+      && hBuild a b c d e f ^. hTuple == abc+++++-- XXX projected+v =  mkVariant (Label :: Label "x") () (Proxy :: Proxy '[Tagged "x" (), Tagged "y" Double])+vy = mkVariant (Label :: Label "y") 2.4 (Proxy :: Proxy '[Tagged "x" (), Tagged "y" Double])++vp1 :: Maybe (Variant '[Tagged "x" ()])+vp1 =  projectVariant v+++vp1_ = fromJust vp1+++vp2 = extendsVariant vp1_ `asTypeOf` v+vp3 = extendsVariant vp1_ `asLabelsOf` v++vp4 = (v ^? projected) `asTypeOf` vp1++vp5 = (projected # fromJust vp1) `asTypeOf` v+++vm1 = v & sameLength . sameLabels . projected %~ (\x -> x :: Variant '[Tagged "x" ()])++vm2 = v & sameLength . sameLabels . projected . sameLabels %~ f2+vm3 = vy & sameLength . sameLabels . projected . sameLabels %~ f2+++f2 (review hMaybied -> [pun| (x) |]) = hBuild (Just (show x)) ^?! hMaybied++f3 :: Show a => Variant '[Tagged "x" a] -> Variant '[Tagged "x" String]+f3 = unvarianted %~ show+++hm1 = Proxy :: HMemberM (Tagged "y" Double) '[Tagged "x" (), Tagged "y" Char] inY => Proxy inY++v2 = fmap (`asLabelsOf` (Proxy :: Proxy '[Label "y"])) (projectVariant v)+v_id = fmap (`asLabelsOf` v) (projectVariant v)+v_id2 = fmap (`asLabelsOf` labelsOf v) (projectVariant v)
− examples/TIPTransform.hs 
@@ -1,81 +0,0 @@-{-# 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---- We start with the examples--newtype MyVal = MyVal Int deriving Show---- 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--class TransTIP op db where-    ttip :: op -> db -> db--instance (HMember op db b, TransTIP' b op (TIP db)) -    => TransTIP op (TIP db) where-    ttip = ttip' (Proxy ::Proxy b)--class TransTIP' (b :: Bool) op db where-    ttip' :: Proxy b -> op -> db -> db---- If op is found in a TIP, update the TIP with op-instance (HTypeIndexed db, HUpdateAtHNat n op db, HUpdateAtHNatR n op db ~ db, HType2HNat op db n)-    => TransTIP' True op (TIP db) where-    ttip' _ = tipyUpdate---- If op is not found in a TIP, it must be a function. Look up--- its argument in a TIP and recur.-instance (HOccurs arg db, TransTIP op db) -    => TransTIP' False (arg -> op) db where-    ttip' _ f db = ttip (f (hOccurs db)) db---main = mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4,-		       show tip5, show tip5']
− examples/TIPTransform.out 
@@ -1,6 +0,0 @@-TIPH[MyVal 20, 1, True]-TIPH[MyVal 20, 2, True]-TIPH[MyVal 20, 1, False]-TIPH[MyVal 20, 21, True]-TIPH[MyVal 21, 1, True]-TIPH[MyVal 21, 1, True]
− examples/TIPTransform.ref 
@@ -1,6 +0,0 @@-TIPH[MyVal 20, 1, True]-TIPH[MyVal 20, 2, True]-TIPH[MyVal 20, 1, False]-TIPH[MyVal 20, 21, True]-TIPH[MyVal 21, 1, True]-TIPH[MyVal 21, 1, True]
− examples/TIPTransformM.hs 
@@ -1,159 +0,0 @@-{-# 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-import Control.Monad.Identity---- We start with the examples--newtype MyVal = MyVal Int deriving Show---- 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 (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--- The TF implementation. When specifying the operation to perform over--- a TIP, we can leave it polymorphic over the monad. The type checker--- will instantiate the monad based on the context.--class Monad m => TransTIPM m op db where-    ttipM :: op -> db -> m db---- Check to see if the operation is a computation whose result--- is in the TIP. The type variable m' of the kind *->* below --- can be instantiated either to a monad type constructor, or (arg->).-instance (Monad m, HMember op db b, TransTIPM' b m (m' op) (TIP db))-    => TransTIPM m (m' op) (TIP db) where-    ttipM = ttipM' (Proxy :: Proxy b)--class Monad m => TransTIPM' (b :: Bool) m op db where-    ttipM' :: Proxy b -> op -> db -> m db---- If op is found in a TIP, update the TIP with op.--- The type variable m' must be equal to the type of the monad--- in which the final result is reported.-instance (Monad m, m ~ m',-	  HTypeIndexed db, HUpdateAtHNat n op db, HUpdateAtHNatR n op db ~ db, HType2HNat op db n)-    => TransTIPM' True m (m' op) (TIP db) where-    ttipM' _ op db = do-                     op' <- op-		     return $ tipyUpdate op' db---- If op is not found in a TIP, 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' False m (arg-> op) db where-    ttipM' _ f db = ttipM (f (hOccurs db)) db--- -} -- !TF--main :: IO ()-main = do-            mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4,-                    show tip5, show tip5']-            tip2 <- tip6-            putStrLn $ "tip2 is" ++ show tip2-            return ()-
− examples/TIPTransformM.out 
@@ -1,8 +0,0 @@-TIPH[MyVal 20, 1, True, 3.5]-TIPH[MyVal 20, 2, True, 3.5]-TIPH[MyVal 20, 1, False, 3.5]-TIPH[MyVal 20, 21, True, 3.5]-TIPH[MyVal 21, 1, True, 3.5]-TIPH[MyVal 21, 1, True, 3.5]-MyVal is now MyVal 5-tip2 isTIPH[MyVal 5, 1, True, 3.5]
− examples/TIPTransformM.ref 
@@ -1,8 +0,0 @@-TIPH[MyVal 20, 1, True, 3.5]-TIPH[MyVal 20, 2, True, 3.5]-TIPH[MyVal 20, 1, False, 3.5]-TIPH[MyVal 20, 21, True, 3.5]-TIPH[MyVal 21, 1, True, 3.5]-TIPH[MyVal 21, 1, True, 3.5]-MyVal is now MyVal 5-tip2 isTIPH[MyVal 5, 1, True, 3.5]
+ examples/broken/Joy.hs view
@@ -0,0 +1,287 @@+{-# OPTIONS -fglasgow-exts #-}+{-# OPTIONS -fallow-overlapping-instances #-}+{-# OPTIONS -fallow-undecidable-instances #-}++--Joy implemented in Haskell... extensible embedded language...++module Joy where++import MainGhcGeneric1++-- Building non-empty lists++type HOne = HSucc HZero+hOne :: HOne+hOne = undefined+type HTwo = HSucc HOne+hTwo :: HTwo+hTwo = undefined+type HThree = HSucc HTwo+hThree :: HThree+hThree = undefined++end :: HNil+end = hNil++instance HList s => Apply HNil s s where+	apply _ s = s+instance (HList s,HList s',HList l,Apply a s s',Apply l s' s'') => Apply (HCons a l) s s'' where+	apply (HCons a l) s = apply l (apply a s :: s')+instance HList s => Apply HZero s (HCons HZero s) where+	apply _ s = hCons hZero s+instance (HNat a,HList s) => Apply (HSucc a) s (HCons (HSucc a) s) where+	apply a s = hCons a s++data Lit a = Lit a+lit :: a -> Lit a+lit a = Lit a+unl :: Lit a -> a+unl (Lit a) = a+instance Show a => Show (Lit a) where+	showsPrec _ (Lit a) = showChar '[' . shows a . showChar ']'+instance HList s => Apply (Lit a) s (HCons a s) where+	apply (Lit a) s = hCons a s++class (HBool b,HList s) => HIfte b t f s s' | b t f s -> s' where+	hIfte :: b -> t -> f -> s -> s'+instance (HList s,Apply t s s') => HIfte HTrue t f s s' where+	hIfte _ t _ s = apply t s+instance (HList s,Apply f s s') => HIfte HFalse t f s s' where+	hIfte _ _ f s = apply f s++data Ifte+ifte :: Ifte+ifte = undefined+instance Show Ifte where+	showsPrec _ _ = showString "If"+instance (Apply b s r,HHead r b',HIfte b' t f s s')+	=> Apply Ifte (f :*: t :*: b :*: s) s' where+	apply _ (HCons f (HCons t (HCons b s))) = hIfte (hHead (apply b s :: r) :: b') t f s++data Nul+nul :: Nul+nul = undefined+instance Show Nul where+	showsPrec _ _ = showString "Nul"+instance HList s => Apply Nul (HCons HZero s) (HCons HTrue s) where+	apply _ (HCons _ s) = hCons hTrue s+instance HList s => Apply Nul (HCons (HSucc n) s) (HCons HFalse s) where+	apply _ (HCons _ s) = hCons hFalse s++data EQ+eq :: EQ+eq = undefined+instance Show EQ where+	showsPrec _ _ = showString "Eq"+instance (HList s,TypeEq a b t) => Apply EQ (HCons a (HCons b s)) (HCons t s) where+	apply _ (HCons a (HCons b s)) = hCons (typeEq a b) s++data Dip+dip :: Dip+dip = undefined+instance Show Dip where+	showsPrec _ _ = showString "Dip"+instance (HList s,HList s',Apply a s s') => Apply Dip (HCons a (HCons b s)) (HCons b s') where+	apply _ (HCons a (HCons b s)) = hCons b (apply a s)++data Dup +dup :: Dup+dup = undefined+instance Show Dup where+	showsPrec _ _ = showString "Dup"+instance HList s => Apply Dup (HCons a s) (HCons a (HCons a s)) where+	apply _ s@(HCons a _) = hCons a s++data Pop+pop :: Pop+pop = undefined+instance Show Pop where+	showsPrec _ _ = showString "Pop"+instance HList s => Apply Pop (HCons a s) s where+	apply _ (HCons _ s) = s++data Swap+swap :: Swap+swap = undefined+instance Show Swap where+	showsPrec _ _ = showString "Swap"+instance HList s => Apply Swap (HCons a (HCons b s)) (HCons b (HCons a s)) where+	apply _ (HCons a (HCons b s)) = hCons b (hCons a s)++data Suc+suc :: Suc+suc = undefined+instance Show Suc where+	showsPrec _ _ = showString "Suc"+instance (HNat a,HList s) => Apply Suc (HCons a s) (HCons (HSucc a) s) where+	apply _ (HCons _ s) = hCons (undefined::HSucc a) s++data Pre+pre :: Pre+pre = undefined+instance Show Pre where+	showsPrec _ _ = showString "Pre"+instance (HNat a,HList s) => Apply Pre (HCons (HSucc a) s) (HCons a s) where+	apply _ (HCons _ s) = hCons (undefined::a) s++data Add+add :: Add+add = undefined+instance Show Add where+	showsPrec _ _ = showString "Add"+instance (HList s,HAdd a b c) => Apply Add (HCons a (HCons b s)) (HCons c s) where+	apply _ (HCons _ (HCons _ s)) = hCons (hAdd (undefined::a) (undefined::b)) s++class (HNat a,HNat b) => HAdd a b c | a b -> c where+	hAdd :: a -> b -> c+instance HAdd HZero HZero HZero where+	hAdd _ _ = hZero+instance HNat b => HAdd HZero (HSucc b) (HSucc b) where+	hAdd _ b = b+instance HNat a => HAdd (HSucc a) HZero (HSucc a) where+	hAdd a _ = a+instance (HNat (HSucc a),HNat (HSucc b),HNat c,HAdd a b c)+	=> HAdd (HSucc a) (HSucc b) (HSucc (HSucc c)) where+	hAdd _ _ = hSucc $ hSucc $ hAdd (undefined::a) (undefined::b)++data Sub+sub :: Sub+sub = undefined+instance Show Sub where+	showsPrec _ _ = showString "Sub"+instance (HList s,HSub a b c) => Apply Sub (HCons b (HCons a s)) (HCons c s) where+	apply _ (HCons _ (HCons _ s)) = hCons (hSub (undefined::a) (undefined::b)) s++class (HNat a,HNat b) => HSub a b c | a b -> c where+	hSub :: a -> b -> c+instance HSub HZero HZero HZero where+	hSub _ _ = hZero+instance HNat a => HSub (HSucc a) HZero (HSucc a) where+	hSub a _ = a+instance HNat a => HSub HZero (HSucc a) HZero where+	hSub _ _ = hZero+instance (HSub a b c) => HSub (HSucc a) (HSucc b) c where+	hSub _ _ = hSub (undefined::a) (undefined::b)+	+data Mult+mult :: Mult+mult = undefined+instance Show Mult where+	showsPrec _ _ = showString "Mult"+instance (HList s,HMult a b c) => Apply Mult (HCons a (HCons b s)) (HCons c s) where+	apply _ (HCons _ (HCons _ s)) = hCons (hMult (undefined::a) (undefined::b)) s++class (HNat a,HNat b) => HMult a b c | a b -> c where+	hMult :: a -> b -> c+instance HNat b => HMult HZero b HZero where+	hMult _ _ = hZero+instance (HMult a b s,HAdd b s s') => HMult (HSucc a) b s' where+	hMult _ _ = hAdd (undefined::b) (hMult (undefined::a) (undefined::b) :: s)++square = dup .*. mult .*. hNil+cube = mult .*. mult .*. dup .*. dup .*. hNil++data I+i :: I+i = undefined+instance Show I where+	showsPrec _ _ = showString "I"+instance Apply I HNil HNil where+	apply _ _ = hNil+instance (HList s,Apply a s s') => Apply I (HCons a s) s' where+	apply _ (HCons a s) = apply a s++data Primrec = Primrec deriving Show+primrec :: Primrec+primrec = undefined+instance Apply z s s' => Apply Primrec (HCons nz (HCons z (HCons HZero s))) s' where+	apply _ (HCons _ (HCons z (HCons _ s))) = apply z s+instance (HList s,Apply Primrec (HCons nz (HCons z (HCons n (HCons (HSucc n) s)))) s',Apply nz s' s'')+	=> Apply Primrec (HCons nz (HCons z (HCons (HSucc n) s))) s'' where+	apply _ (HCons nz (HCons z s@(HCons _ _))) = apply nz (apply Primrec (hCons nz (hCons z (hCons (undefined::n) s))))++data Times+times :: Times+times = undefined+instance Show Times where+	showsPrec _ _ = showString "Times"+instance HList s => Apply Times (HCons p (HCons HZero s)) s where+	apply _ (HCons _ (HCons _ s)) = s+instance (HNat n,HList s,HList s',Apply p s s',Apply Times (HCons p (HCons n s')) s'')+	=> Apply Times (HCons p (HCons (HSucc n) s)) s'' where+	apply _ (HCons p (HCons _ s)) = apply times (hCons p (hCons (undefined::n) (apply p s)))++class (HBool f,HList s) => HGenrec f r1 r2 b t s s'' | f r1 r2 b t s -> s'' where+	hGenrec :: f -> r1 -> r2 -> b -> t -> s -> s''+instance (HList s,Apply t s s') => HGenrec HTrue r1 r2 b t s s' where+	hGenrec _ _ _ _ t s = apply t s+instance (HList s,HList s',Apply r1 s s',+	Apply (HCons (Lit (HCons (Lit b) (HCons (Lit t) (HCons (Lit r1) (HCons (Lit r2) (HCons Genrec HNil)))))) (HCons r2 HNil)) s' s'')+	=> HGenrec HFalse r1 r2 b t s s'' where+	hGenrec _ r1 r2 b t s = apply (hCons (lit (hCons (lit b) (hCons (lit t) (hCons (lit r1) (hCons (lit r2) (hCons genrec hNil)))))) (hCons r2 hNil)) (apply r1 s :: s') ++data Genrec+genrec :: Genrec+genrec = undefined+instance Show Genrec where+	showsPrec _ _ = showString "Genrec"+instance (Apply b s s',HHead s' b',HGenrec b' r1 r2 b t s s'')+	=> Apply Genrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where+	apply _ (HCons r2 (HCons r1 (HCons t (HCons b s))))+		= hGenrec (hHead (apply b s :: s') :: b') r1 r2 b t s++class (HBool f,HList s) => HLinrec f b t r1 r2 s s' | f b t r1 r2 s -> s' where+	hLinrec :: f -> b -> t -> r1 -> r2 -> s -> s'+instance (HList s,Apply t s s') => HLinrec HTrue b t r1 r2 s s' where+	hLinrec _ _ t _ _ s = apply t s+instance (HList s,HList s',Apply r1 s s',+	Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s')))) s'',Apply r2 s'' s''')+	=> HLinrec HFalse b t r1 r2 s s''' where+	hLinrec _ b t r1 r2 s = apply r2 (apply linrec (hCons r2 (hCons r1 (hCons t (hCons b (apply r1 s :: s'))))) :: s'')++data Linrec+linrec :: Linrec+linrec = undefined+instance Show Linrec where+	showsPrec _ _ = showString "Linrec"+instance (Apply b s s',HHead s' b',HLinrec b' b t r1 r2 s s'') => Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where+	apply _ (HCons r2 (HCons r1 (HCons t (HCons b s)))) = hLinrec (hHead (apply b s :: s') :: b') b t r1 r2 s++data Fact+fact :: Fact+fact = undefined+instance Show Fact where+	showsPrec _ _ = showString "Fact"+instance (HList s,Apply (HCons (Lit (HCons (Lit HZero) (HCons EQ HNil)))+	(HCons (Lit (HCons Pop (HCons (Lit HOne) HNil)))+	(HCons (Lit (HCons Dup+	(HCons (Lit HOne)+	(HCons Sub (HCons Fact (HCons Mult HNil))))))+	(HCons Ifte HNil)))) s s') => Apply Fact s s' where+	apply _ s = apply fac1 s++fac1 = hCons (lit (hCons (lit hZero) (hCons eq hNil)))+	(hCons (lit (hCons pop (hCons (lit hOne) hNil)))+	(hCons (lit (hCons dup (hCons (lit hOne) (hCons sub (hCons fact (hCons mult hNil))))))+	(hCons ifte hNil)))++fac2 = lit (hOne .*. hOne .*. end)+	.*. dip .*. lit (dup .*. lit mult .*. dip .*. suc .*. end)+	.*. times .*. pop .*. end++fac3 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end)+	.*. lit (i .*. mult .*. end) .*. genrec .*. end++fac4 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end)+	.*. lit mult .*. linrec .*. end++fac5 = lit hOne .*. lit mult .*. primrec .*. end++main :: IO ()+main = do+	putStrLn $ show $ apply (lit hThree .*. fac1 .*. end) end+	putStrLn $ show $ apply i (fac2 .*. hThree .*. end)+	putStrLn $ show $ apply i (fac3 .*. hThree .*. end)+	putStrLn $ show $ apply i (fac4 .*. hThree .*. end)+	putStrLn $ show $ apply i (fac5 .*. hThree .*. end)+
− examples/cmdargs.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE TemplateHaskell #-}-module Main where-import System.Console.CmdArgs-import Data.HList.CommonMain-import Data.Generics---{---An example showing off the data instance for Record--Also a use of cmdArgs--NOTE: the data instances do not work with ghc-7.8 because of-<http://ghc.haskell.org/trac/ghc/ticket/8486>----}--makeLabels6 (words "x y z")---d0 = x .=. (5 :: Int)-    .*. y .=. True-    .*. z .=. False-    .*. emptyRecord---data E = E { a :: Int, b, c :: Bool }-    deriving (Show, Data, Typeable)-e0 = E 5 True False--main = do-    print d0-    print $ gmapT (mkT not) d0-    print $ gmapT (mkT (+(1::Int))) d0--    print $ fromConstrB (undefined `extB` (1::Int) `extB` True) undefined `asTypeOf` d0--    rc <- cmdArgs d0-    print rc-
− examples/cmdargs.out 
@@ -1,5 +0,0 @@-Record{x=5,y=True,z=False}-Record{x=5,y=False,z=True}-Record{x=6,y=True,z=False}-Record{x=1,y=True,z=True}-Record{x=5,y=True,z=False}
− examples/cmdargs.ref 
@@ -1,5 +0,0 @@-Record{x=5,y=True,z=False}-Record{x=5,y=False,z=True}-Record{x=6,y=True,z=False}-Record{x=1,y=True,z=True}-Record{x=5,y=True,z=False}
− examples/labelable.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds #-}-{- | 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--makeLabelable "x y"--r = x .==. "hi" .*.-    y .==. (y .==. 321 .*. x .==. 123 .*. emptyRecord) .*.-    emptyRecord--main = do-    print (r ^. x)-    print (r & x .~ ())--    print (r ^. y . y)-    print (r & y . y .~ "xy")
− examples/labelable.out 
@@ -1,4 +0,0 @@-"hi"-Record{x=(),y=Record{y=321,x=123}}-321-Record{x="hi",y=Record{y="xy",x=123}}
− examples/labelable.ref 
@@ -1,4 +0,0 @@-"hi"-Record{x=(),y=Record{y=321,x=123}}-321-Record{x="hi",y=Record{y="xy",x=123}}
− examples/lens.hs 
@@ -1,34 +0,0 @@-{-# 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")--r = x .=. "hi" .*.-    y .=. (y .=. 321 .*. x .=. 123 .*. emptyRecord) .*.-    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")-
− examples/lens.out 
@@ -1,11 +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}}
− examples/lens.ref 
@@ -1,11 +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}}
− examples/pun.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns #-}--- more examples for record puns-module Main where-import Data.HList.CommonMain--makeLabels6 (words "a b c")---r  = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord-r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord---p1 ( (.!. b) -> (b @ ((.!. a) -> a))) = (a,b)--p2 [pun| b @ {a} |] = (a, b)---- same as p2, but gives a warning--- p3 [pun| b @ a |] = (a, b)--p4 [pun| b{a} |] = a -- b is not bound---- adds `x' and `y' into a field called r-e1 = let x = 1; y = "hi" in [pun| r @ { x y } |]---- updates the `c' field-e2 = let c = 1; y = "hi" in [pun| r @ { c y } |]---- same as e1, but doesn't use a pre-existing r-e3 = let x = 1; y = "hi" in [pun| r { x y } |]---main = do-        putStrLn "similar:"-        print $ p1 r-        print $ p2 r-        print $ p4 r--        putStrLn "\nexpression QQ:"-        print $ e1-        print $ e2-        print $ e3-
− examples/pun.out 
@@ -1,9 +0,0 @@-similar:-(3,Record{a=3})-(3,Record{a=3})-3--expression QQ:-Record{r=Record{b=Record{a=3},c="c",x=1,y="hi"}}-Record{r=Record{b=Record{a=3},c=1,y="hi"}}-Record{r=Record{x=1,y="hi"}}
− examples/pun.ref 
@@ -1,9 +0,0 @@-similar:-(3,Record{a=3})-(3,Record{a=3})-3--expression QQ:-Record{r=Record{b=Record{a=3},c="c",x=1,y="hi"}}-Record{r=Record{b=Record{a=3},c=1,y="hi"}}-Record{r=Record{x=1,y="hi"}}
examples/rundoctests.hs view
@@ -1,10 +1,12 @@+import Data.List import System.Process import System.Exit import System.IO-import Test.DocTest import Data.Char import System.Environment +import Cabal+ -- | tests that all the >>> comments are followed by correct output. Easiest is to -- -- > cabal test@@ -20,21 +22,26 @@ -- you need Cabal >= 1.18 since that's around when cabal repl got added. main = do     as <- getArgs-    o <- readProcess-        "cabal" ["repl","--ghc-options","-v0 -w"]+    (ExitSuccess, o, _) <- cabal+        ["repl","--ghc-options","-v0 -w"]         ":show packages\n:show language"-    let flags = words $ unlines $ filter ((=="-") . take 1 . dropWhile isSpace)+    let flags = words $ unlines+                    $ filter (\f -> not $ "package" `isInfixOf` f)+                    $ filter ((=="-") . take 1 . dropWhile isSpace)                     $ lines o      let files = case as of             [] -> ["Data/HList/CommonMain.hs",                    "Data/HList/HList.hs",                    "Data/HList/Record.hs",-                   "Data/HList/Labelable.hs"]+                   "Data/HList/Labelable.hs",+                   "Data/HList/HSort.hs"]             _ -> as -    doctest $ "-i.": "-idist/build/autogen":+    let args = "-i.": "-idist/build/autogen":              "-optP-include":              "-optPdist/build/autogen/cabal_macros.h" :              "-Idist/build/autogen" : "-w":              files ++ flags+    readProcess "doctest" args ""+
− examples/runexamples.hs 
@@ -1,51 +0,0 @@-module Main where--import Control.Exception-import System.FilePath-import Test.Hspec-import System.Process-import System.Exit-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"-        refFile = dropExtension inFile ++ ".ref"--    (ec, stdout, stderr) <- readProcessWithExitCode "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] "" else return Nothing--    return (ec, stderr, diff)- `shouldReturn` (ExitSuccess, "", Just "")----allM [] = return True-allM (x:xs) = do-    x <- x-    if x then allM xs else return False