packages feed

HList 0.3.4.1 → 0.4.0.0

raw patch · 78 files changed

+8959/−2452 lines, 78 filesdep +QuickCheckdep +arraydep +base-orphansdep ~basesetup-changed

Dependencies added: QuickCheck, array, base-orphans, profunctors

Dependency ranges changed: base

Files

ChangeLog view
@@ -1,3 +1,165 @@+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,31 +11,145 @@  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+++ -- * 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@. 'hLens'' is an exception to this rule.++ , TypeIndexed(..)+ , typeIndexed'+ -- ** HList and Record+ -- | 'unlabeled' 'unlabeled''++ -- ** HList and TIP+ , tipHList, tipHList'++ -- ** 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'++ -- ** Record and Variant+ , hMaybied, hMaybied'+ -- *** 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+ {- | there are three options for now. However, there are    a couple different styles for the first option here:     GHC supports type-level strings ('GHC.TypeLits.Symbol'), and these can be-   labels. You can refer to these strings using an unwieldy syntax. 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:+   labels. You can refer to these strings using an unwieldy syntax described+   below. For example if you want to store a value @5@ in a record @rec@+   with a field called @\"x\"@, and then get it out again:     let rec = ('Label' :: Label \"x\") '.=.' 5 '.*.' 'emptyRecord' @@ -47,7 +161,7 @@     > rec .!. x -   See 'makeLabels6' for automating the @x = Label :: Label \"x\"@.+   'makeLabels6' automates definitions like @x = Label :: Label \"x\"@.   -}  -- $label6demo@@ -58,18 +172,23 @@  -- ** 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 +197,32 @@ import Data.HList.HOccurs import Data.HList.HTypeIndexed import Data.HList.Record-import Data.HList.HList+-- import Data.HList.RecordU+-- 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 @@ -114,12 +249,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 +274,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,53 @@     -- * 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  -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 = (HBuild' '[] g,         Typeable (HListFlat a),         TypeablePolyK a,         HFoldl (GfoldlK  C) (C g) a (C (HList a)),@@ -99,12 +106,14 @@         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+instance DataHListFlatCxt na g a => Data (HListFlat a) where     gfoldl k z (HListFlat xs) = c3 $                     hFoldl                         (c1 (GfoldlK k))@@ -182,7 +191,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 +211,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 +221,23 @@ 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+#if !MIN_VERSION_base(4,8,0)+-- GHC 7.9 adds these instances+deriving instance Typeable '[]+deriving instance Typeable '(:)+#endif+ #else instance TypeRepsList (Record xs) => Typeable (HList xs) where    typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.HList" "HList")@@ -228,48 +247,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/FakePrelude.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE OverlappingInstances #-}--- just for the proxy+{-# LANGUAGE CPP #-}  {- |    The HList library@@ -11,31 +10,70 @@  module Data.HList.FakePrelude     (module Data.HList.FakePrelude,-     module Data.Proxy) where+     module Data.Proxy,+     module Data.Tagged,+     Monoid(..)) where  import Data.Proxy+import Data.Tagged import GHC.Prim (Constraint) import GHC.TypeLits+import Control.Applicative+#if NEW_TYPE_EQ+import Data.Type.Equality (type (==))+#endif +#if !OLD_TYPEABLE+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ < 709+import Data.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 +94,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 +161,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 +178,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@@ -230,7 +312,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 +331,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 +400,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 +412,7 @@  -- | `demote' to values hAnd :: Proxy t1 -> Proxy t2 -> Proxy (HAnd t1 t2)-hAnd = undefined+hAnd _ _ = Proxy   -- ** Disjunction@@ -316,7 +423,7 @@  -- | `demote' to values hOr :: Proxy t1 -> Proxy t2 -> Proxy (HOr t1 t2)-hOr = undefined+hOr _ _ = Proxy  {- $boolHistoricalNote @@ -343,7 +450,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,9 +495,9 @@ 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@@ -389,10 +508,21 @@ instance HNat2Integral n => HNat2Integral (HSucc n) where     hNat2Integral n = hNat2Integral (hPred n) + 1 -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 +542,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 +577,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,45 +630,37 @@ --  * 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 --- | A predicate for type equality------ There are different implementations: see TypeEq*.hs -class HBool b => TypeEq x y b | x y -> 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. --- Rely on lazy show for type-level Booleans-typeEq :: TypeEq t t' b => t -> t' -> b-typeEq = undefined+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) --- A more disciplined version: based on proxies-proxyEq :: TypeEq t t' b => Proxy t -> Proxy t' -> b-proxyEq _ _ = undefined+-- | 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 --- ----------------------------------------------------------------------------- * Type-safe cast -- no longer need. We use a a ~ b+instance HCast1 False x y where+    hCast1 _ _ = Nothing -{--class TypeCast x y | x -> y, y -> x- where-  typeCast :: x -> y--}  + -- --------------------------------------------------------------------------  -- * Error messages@@ -498,3 +669,101 @@ class Fail x  +-- ** Uses of fail+-- $note these could be replaced by `'("helpful message", l)`,+-- but these look better.+data ExtraField l+data FieldNotFound l+++#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++  {- | @SameLength x y => Equality (r x) (q y) (r x) (q 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++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)+++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)++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
@@ -60,6 +60,9 @@   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) +instance Fail (FieldNotFound (Proxy n, e1)) => HUpdateAtHNat n e1 '[] where+  type HUpdateAtHNatR n e1 '[] = '[]+  hUpdateAtHNat _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances"  -- -------------------------------------------------------------------------- -- * Projection@@ -70,7 +73,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 +83,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 +93,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 +106,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 +134,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 +150,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 +171,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
@@ -15,1023 +15,1573 @@ 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))----}+import Text.ParserCombinators.ReadP+import Data.List++import LensDefs++import Data.Array (Ix)++-- --------------------------------------------------------------------------+-- * 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.++-}+++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) = let 'H':'[':s = show l+                       in "H[" ++ show x +++                                  (if s == "]" then s else "," ++ 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 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++++++-- * 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@)++> 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, HAppendList t (HConcatR xs)) => HConcat (x ': xs) where+    type HConcatR (x ': xs) = HAppendListR (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.++>>> :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 n => HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n+instance HFind1 e l n => HFind e l n++class HFind1 (e :: k) (l :: [k]) (n :: HNat) | e l -> n++instance (HEq e1 e2 b, HFind2 b e1 l n) => HFind1 e1 (e2 ': l) n+instance Fail (FieldNotFound e1) => HFind1 e1 '[] HZero++class HFind2 (b::Bool) (e :: k) (l::[k]) (n:: HNat) | b e l -> n+instance HFind2 True e l HZero+instance HFind1 e l n => HFind2 False e l (HSucc n)++++-- ** 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 = simple (listAsHList (simple 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+++-- | @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+++-- * 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 = simple (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 revFst snd,+          HReverse revFst fst,++          HRevApp revFst snd y)+    => HSpanEqBy f x y fst snd where+  hSpanEqBy f x y =  case hSpanEqBy1 f x y of+                      (revFst, second) -> (hReverse revFst, second)++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))+  mappend 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/HList/HListPrelude.hs view
@@ -13,11 +13,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 +57,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 +76,21 @@  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+
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@@ -84,24 +84,31 @@  instance (HOccurrence e (x ': y) l', HOccurs' e l')     => HOccurs e (HList (x ': y)) where-    hOccurs = hOccurs' . hOccurrence (undefined::e)+    hOccurs = hOccurs' . hOccurrence (Proxy ::Proxy e)  class HOccurs' e l where     hOccurs' :: HList l -> e  instance Fail (TypeNotFound e) => HOccurs' e '[] where-    hOccurs' = undefined+    hOccurs' = error "Data.HList.FakePrelude.Fail must have no instances"  instance (e ~ e1, HOccursNot e l) => HOccurs' e (e ': l) 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
+ Data/HList/HSort.hs view
@@ -0,0 +1,256 @@+{-# 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,+         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) => 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) =>+    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,+          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 (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 (HSortBy lt ps ps', HIsAscList lt ps' b) => HIsSetBy lt ps b+++-- | @HAscList le xs@ confirms that xs is in ascending order,+-- and reports which element is duplicated otherwise.+class HEqByFn le => HAscList le (ps :: [*])++instance HAscList0 le ps ps => HAscList le ps++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)+  => 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
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,45 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#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 _ = (\(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,174 @@ 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(toLabel),     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)) +-- | make a @Lens (Record s) (Record t) a b@+instance HLens x Record s t a b+        => Labelable x Record s t a b where+            type LabelableTy Record = LabelableLens+            hLens' = hLens --- | 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+-- | 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 ~ ()) --- | extracts the type that is actually the label in @a@ and puts it in @b@-class ToSym 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 --- | for labels in this module-instance (x ~ x', p ~ Labeled x') => ToSym (p a b) x'+-- | @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+instance (TICPrism s t a b, x ~ a, a ~ b, s ~ t,+          SameLength s t) =>+    Labelable (x :: *) TIC s t a b where+      type LabelableTy TIC = LabelablePrism+      hLens' _ = ticPrism --- | for "Data.HList.Label6" labels-instance (x ~ x') => ToSym (Label x) x' -toLabel :: ToSym t t' => t -> Label (t' :: Symbol)-toLabel _ = Label+-- | 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 TIP s t a b where+    type LabelableTy TIP = LabelableLens+    hLens' = hLens +type LabelableTIPCxt x s t a b =+     (s ~ t, a ~ b, x ~ a,+      HLens x TIP s t a b)  -{- | @makeLabelable \"x y z\"@ will generate haskell identifiers that work with '.==.' and-are also lenses.+-- | 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 -> x = hLens' (Label :: Label "x")-> y = hLens' (Label :: Label "y")-> z = hLens' (Label :: Label "z")+infixr 4 .==. ++{- | Create a @'Label' (x :: 'Symbol')@:++> toLabel :: LabeledTo x _ _ -> Label x+> toLabel :: Label x         -> Label x+> toLabel :: Proxy x         -> Label x+ -}-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)+class ToSym label (s :: Symbol) | label -> s where+    toLabel :: label -> Label s -                  makeSig = [t| Labelable $l p f s t a b => p (a -> f b) (Record s -> f (Record t)) |]+instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3+    => ToSym (v1 v2 v3) x where+      toLabel _ = Label +instance ToSym (label x) x where+    toLabel _ = Label + {- $comparisonWithhLensFunction  Note that passing around variables defined with 'hLens'' doesn't get@@ -165,4 +212,114 @@ 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 = simple (projected (simple 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
@@ -7,12 +7,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 +34,7 @@     c = make_cname n     d = make_dname n -    dd = dataD (return []) c [] [] [{- 'Typeable -}]+    dd = dataD (return []) c [] [] [''Typeable]      labelSig = sigD d [t| Label $(conT c) |] @@ -39,13 +43,6 @@                   (normalB [| Label |])                   [] -    showLabelInst = instanceD-            (return [])-            [t| ShowLabel $(conT c) |]-            [valD (varP 'showLabel)-                (normalB [| \_ -> n |])-                [] ]-     showInst = instanceD             (return [])             [t| Show $(conT c) |]@@ -59,13 +56,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 +70,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 +108,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
@@ -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,74 @@      -- ** 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+    zipTagged,+    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)+ -- imports for doctest/examples import Data.HList.Label6 () import Data.HList.TypeEqO ()@@ -187,46 +244,121 @@ l .=. v = newLVPair l v  -newtype Record (r :: [*]) = Record (HList r) -- deriving Eq+newtype Record (r :: [*]) = Record (HList 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 = simple (isoNewtype Record (\(Record r) -> r) 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 = simple (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,19 +368,32 @@          ) => 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) @@ -262,14 +407,13 @@ 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 +443,57 @@      ++ 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)) => 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 +514,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 +534,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 +545,54 @@         (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 +instance Fail (FieldNotFound l) => HasField l (Record '[]) (FieldNotFound l) 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 +643,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 +671,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 +681,53 @@ -- 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)++instance Fail (FieldNotFound l) => HUpdateAtLabel2 l v '[] '[] where+    hUpdateAtLabel2 _ _ r = r++ infixr 2 .@. {-| @@ -485,24 +751,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,15 +810,15 @@ 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@@ -546,12 +846,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 +873,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 +951,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 +967,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 +994,335 @@  -- -------------------------------------------------------------------------- -- | 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 = simple (rearranged (simple 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+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_ :: (Eq a, Enum a, Bounded 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 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+++instance (RecordValuesR lvs ~ vs,+          SameLabels ls lvs,+          LabelsOf lvs ~ ls,+          SameLengths [ls,vs,lvs],+          HAllTaggedLV lvs)+    => HUnzip Proxy ls vs lvs where+    hUnzip _ = (Proxy, Proxy)++instance HUnzip Proxy ls vs lvs+      => HZip Proxy ls vs lvs where+  hZip _ _ = Proxy+++{- | 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++++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
@@ -62,41 +62,69 @@ restricts the fields in the record supplied to be exactly the ones provided. In other words -> [pun| (x y) |] = list+> [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@.+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"  }  +-- | 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+ -- like  \x -> (x .!. x1, x .!. x2) extracts xs = do     record <- newName "record"-    lamE [varP record]-        (tupE+    let val = tupE             [ [| $(varE record) .!. $label  |]                 | x <- xs,-                let label = [| Label :: Label $(litT (strTyLit x)) |]-                ])+                let label = [| Label :: Label $(litT (strTyLit x)) |],+                x /= "_"+                ] -mkExp :: [String] -> ExpQ-mkExp xs = foldr (\x acc -> [| $(mkPair x (dyn x)) .*. $acc |]) [| emptyRecord |] xs+        -- constrain the type of the supplied record to have at least+        -- as many elements as are extracted. In other words:+        --+        -- > f :: r (e1 ': e2 ': e3 ': e4 ': es) -> () -- is inferred+        -- > f [pun| { _ _ _ _ } |] = ()+        ensureLength = [| $(varE record) `asTypeOf` $(minLen xs) |] +    lamE [varP record] [|  $val `const` $ensureLength |]+++-- | generates an @undefined :: r xs@, such that @xs :: [k]@ has+-- at least as long as the input list+minLen :: [t] -> ExpQ+minLen [] = [| error "Data.HList.RecordPuns.minLen" :: r (es :: [*]) |]+minLen (_ : xs) = [| (error "Data.HList.RecordPuns.minLen"+                        :: r es -> r (e ': es)) $(minLen xs) |]+ mkPair :: String -> ExpQ -> ExpQ mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |] @@ -119,20 +147,21 @@                         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' [])+          (conP 'HNil [])           (mps as))] mp a = do     reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a@@ -142,6 +171,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/TIC.hs view
@@ -1,60 +1,200 @@-{-# 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)++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) ++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 = simple (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 = simple (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,47 @@    (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.HOccurs+import Data.HList.TIPtuple+import Data.List (intercalate)+import Data.Array (Ix) -import Data.HList.TypeEqO () -- for doctest+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 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 +56,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 +86,87 @@ -- 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 = simple (tipyLens x) -- rejected by GHC-7.10RC1+#else+tipyLens' f s = simple (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 s = hLens x f (asTIP s)+  where+    x = getA f+    getA :: (a -> f b) -> Label a+    getA _ = Label++    asTIP :: TIP a -> TIP a+    asTIP = id+++-- | 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 +179,271 @@   -- --------------------------------------------------------------------------+-- * 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 = 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 = simple (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 = simple (tipRecord x)++-- --------------------------------------------------------------------------+-- * Zip++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++-- | 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 '(TypeNotFound notfun, "in TIP", db) => TransTIP1 False HZero notfun db where+    ttip1 = error "TransTIP1 Fail must have no instances"++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 '(TypeNotFound arg, "in TIP", db) => TransTIP2 False arg op db where+    ttip2 = error "TransTIP2 Fail must have no instances"++-- ** 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 '(TypeNotFound op, "in TIP", db), Monad m)+    => TransTIPM1 False HZero m op db where+    ttipM1 _ _ = error "TransTIPM1 Fail must have no instances"++-- 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 '(TypeNotFound op, "in TIP", db))+    => TransTIPM2 False m arg op db where+    ttipM2 _ _ = error "TransTIPM1 Fail must have no instances"++-- --------------------------------------------------------------------------++-- 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 +451,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 :}@@ -141,16 +473,23 @@ 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 +497,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,1168 @@-{-# 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.Prim (Any)+import GHC.Exts (Constraint)++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),+          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)+++-- * Monoid+instance (Unvariant '[Tagged t x] x, Monoid x) => Monoid (Variant '[Tagged t x]) where+    mempty = mkVariant (Label :: Label t) mempty Proxy+    mappend a b = case (unvariant a, unvariant b) of+                    (l, r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+++-- | XXX check this mappend is legal+instance (Monoid x, Monoid (Variant (a ': b))) => Monoid (Variant (Tagged t x ': a ': b)) where+    mempty = extendVariant mempty+    mappend a b = case (splitVariant1 a, splitVariant1 b) of+                    (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++-- * 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
+ Data/HList/broken/RecordU.hs view
@@ -0,0 +1,462 @@+{- | Description: records where elements are stored in unboxed arrays++XXX works with ghc-7.8 and 7.6. Broken with GHC-7.10 RC1 on account of ghc+bug #10009++The public interface is exported from <Data-HList-CommonMain.html#t:RecordU RecordU>++Export list (from CommonMain.hs)++@+ -- ** 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++++ -- ** Record and RecordU+ , unboxed, unboxed'+ -- ** Record and RecordUS+ , unboxedS, unboxedS'+@+-}+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 Data.HList.HOccurs+import LensDefs++import Data.HList.Labelable++import Unsafe.Coerce+import GHC.Exts (Any)++-- * 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 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 updates the very first elements+  of the 'RecordU'++The benefit is that lookups should be faster and records+should take up less space. However benchmarks 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) (Record 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 = simple (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.+  (HConcatR g ~ x,+   HConcat g,+   HMapCxt HList BoxF u g,+   HMapUnboxF g u,+   RecordUSCxt x u+  ) => RecordUS x -> Record x+recordUSToRecord rus = Record (hConcat 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 = simple (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 = simple (unboxed x)+++class RecordToRecordU x where+    recordToRecordU :: Record x -> RecordU x++instance (+    RecordValues x,+    HList2List (RecordValuesR x) (GetElemTy x),+    HNat2Integral (HLength x),+    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' = hLens++{- 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"+-}
+ Data/HList/broken/VariantOld.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-}+++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Variants, i.e., labelled sums.++   One approach to their implementation would be to consider both+   the favoured label and the corresponding value as dynamics upon+   variant construction. Since we are too lazy to programme some+   Typeable instances for non-ghc systems (NB: in GHC, Typeable+   is derivable), we rather model variants as (opaque) records+   with maybies for the values. Only one value will actually hold+   non-Nothing, as guaranteed by the constructor.++   See VariantP.hs for a different approach to open sums.+-}++module Data.HList.Variant where++import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.HList+++-- --------------------------------------------------------------------------+-- | Variant types on the basis of label-maybe pairs.++newtype Variant mr = Variant mr+++-- --------------------------------------------------------------------------+-- | Turn proxy sequence into sequence of Nothings++data HMaybeF = HMaybeF+instance ((Tagged l (Proxy t) ~ a, b ~ Tagged l (Maybe t))) =>  ApplyAB HMaybeF a b   where+    applyAB _ _ = Tagged Nothing++hMaybied x = hMap HMaybeF x+++-- --------------------------------------------------------------------------+-- | Public constructor+-- it seems we can blame 'hUpdateAtLabel' (not 'HMap') for needing the asTypeOf?+mkVariant x y (Record v) = let r1 = Record (hMaybied v) in+    case hUpdateAtLabel x (Just y) r1 `asTypeOf` r1 of+    Record t -> Variant t++-- --------------------------------------------------------------------------+-- | Public destructor++unVariant x (Variant v) = hLookupByLabel x (Record v)+++-- --------------------------------------------------------------------------+-- | Variants are opaque++instance Show (Variant v)+ where+  show _ = "<Cannot show Variant content!>"++
HList.cabal view
@@ -1,10 +1,17 @@ Name:                HList-Version:             0.3.4.1+Version:             0.4.0.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 License:             MIT@@ -15,16 +22,16 @@  Data-files:          README, ChangeLog Cabal-version:       >= 1.10-Tested-With:         GHC==7.6.2, GHC==7.7+Tested-With:         GHC==7.6.3, GHC==7.8.4, GHC==7.10.1 Build-Type:          Simple  Extra-Source-Files:                      examples/*.hs,+                     examples/Properties/*.hs,                      examples/broken/*.hs,                      examples/broken/*.lhs,                       examples/*.ref,-                     examples/*.out,                       examples/broken/*.ref, @@ -36,22 +43,38 @@     location: http://code.haskell.org/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)+ library-  Build-Depends:       base >= 4 && < 5, template-haskell, ghc-prim, mtl,-                       tagged+  Build-Depends:       base >= 4.6 && < 4.9,+                       template-haskell,+                       ghc-prim,+                       mtl,+                       tagged,+                       profunctors,+                       array +   Exposed-modules:     Data.HList,                        Data.HList.CommonMain,                        Data.HList.Data,                        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,@@ -59,44 +82,86 @@                        Data.HList.RecordPuns,                        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 < 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++  if flag(new_type_eq)+    Cpp-options:       -DNEW_TYPE_EQ+    Build-Depends:     base >= 4.7+ Test-Suite examples   Type:     exitcode-stdio-1.0   Ghc-Options: -threaded-  Main-Is: examples/runexamples.hs+  Main-Is: runexamples.hs   Default-Language:    Haskell2010+  Hs-Source-Dirs:  examples   Build-Depends:       base, hspec >= 1.7, directory, filepath,                        process, syb, cmdargs, lens, HList, mtl  Test-Suite doctests   Type:     exitcode-stdio-1.0   Ghc-Options: -threaded-  Main-Is: examples/rundoctests.hs+  if impl(ghc <= 7.9)+    -- doctests include things like :t pred . maxBound, which+    -- depending on the ghc version, comes out as one of+    -- (Bounded a, Enum a) => ...+    -- (Enum b, Bounded b) => ...+    Buildable: False+  Main-Is: rundoctests.hs+  Hs-Source-Dirs:  examples   Build-Depends: base, doctest >= 0.8, process+  Default-Language:    Haskell2010+++Test-Suite properties+  Type:     exitcode-stdio-1.0+  Build-Depends: base,+                 hspec >= 1.7,+                 HList,+                 lens,+                 mtl,+                 QuickCheck,+                 template-haskell,+                 array,+                 syb+  Main-Is:  Properties.hs+  Hs-Source-Dirs: examples   Default-Language:    Haskell2010
+ LensDefs.hs view
@@ -0,0 +1,58 @@+{-# 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++simple :: p a (f a) -> p a (f 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
@@ -45,7 +45,7 @@ $ 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.+for GHC-7.6 and GHC-7.8 and GHC-7.10. Older compilers are not supported.  One may run "cabal test" to check the distribution.
− Setup.hs 
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks
+ Setup.lhs view
@@ -0,0 +1,114 @@+#!/usr/bin/runhaskell+\begin{code}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Language.Haskell.Extension+    ( Extension(EnableExtension, UnknownExtension, DisableExtension) )+import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package+    ( PackageName(PackageName),+      PackageId,+      InstalledPackageId,+      packageVersion,+      packageName )+import Distribution.PackageDescription ()+import Distribution.Simple+    ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils+    ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ()+import Distribution.Simple.LocalBuildInfo ()+import System.FilePath ( (</>) )+import Distribution.Verbosity ( Verbosity )+import Distribution.PackageDescription ()+import Distribution.Simple.LocalBuildInfo ()+import Distribution.PackageDescription+    ( TestSuite(testName),+      PackageDescription,+      Library(libBuildInfo),+      allExtensions )+import Distribution.Simple.Compiler ()+import Distribution.Simple.Setup+    ( BuildFlags(buildVerbosity),+      ConfigFlags(..),+      Flag(Flag, NoFlag),+      fromFlag )+import Distribution.Simple.LocalBuildInfo+    ( LocalBuildInfo(configFlags),+      ComponentLocalBuildInfo(componentPackageDeps),+      withTestLBI,+      withLibLBI )+import Data.Maybe++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+     buildHook simpleUserHooks pkg lbi hooks flags+  }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withLibLBI pkg lbi $ \ lib libcfg -> do+    withTestLBI pkg lbi $ \suite suitecfg -> do+      rewriteFile (dir </> "Build_" ++ testName suite ++ ".flags") $ unlines $+        [ hc , unwords (formatdeps (testDeps libcfg suitecfg) ++ exts lib) ]+  where+    hc = case configHcPath (configFlags lbi) of+            Flag a -> a+            NoFlag -> fromMaybe "ghc" (lookup "ghc" (configProgramPaths (configFlags lbi)))+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> "-package=" ++ n ++ "-" ++ showVersion (packageVersion p)++    exts lib = [ "-X" ++ se+                    | e <- allExtensions (libBuildInfo lib),+                      Just se <- [case e of+                        EnableExtension x -> Just (show x)+                        UnknownExtension x -> Just x+                        DisableExtension x -> Just ("No" ++ show x)+                  ]+                ]++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+++\end{code}+Adapted from:++Copyright 2012-2015 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ examples/Cabal.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+module Cabal where++import System.Process+import System.Exit+import Control.Monad++-- | > cabal args stdin = readProcessWithExitCode "cabal" args stdin+--+-- except it also tries to runghc Setup which can succeed (because+-- if things have been configured with runghc Setup, then a different+-- version of the Cabal library is chosen and cabal complains instead+-- of reconfiguring / using an older Cabal library+cabal :: [String] -> String+  -> IO (ExitCode, String, String)+cabal args stdin = do+#if __GLASGOW_HASKELL__ > 707+  cabalRepl @ (ec, _, _) <- readProcessWithExitCode "cabal" args stdin+  if ec == ExitSuccess then return cabalRepl+    else do+      runghcRepl @ (ec2, _, _) <- readProcessWithExitCode "runghc" ("Setup.lhs":args) stdin+      when (ec2 /= ExitSuccess) $ do+        putStrLn "Could not \"cabal ...\" (exitCode,stdout,stderr):"+        print cabalRepl+        putStrLn "Could not \"runghc Setup ...\" (exitCode,stdout,stderr):"+        print runghcRepl++        putStrLn "\"...\" above is "+        putStrLn "Command:"+        print ("cabal" : args)+        putStrLn "stdin:"+        print stdin+        return ()++      return runghcRepl+#else+  -- we don't have a cabal repl (at least if we're using the Cabal that ghc+  -- comes with), so read a file written by the ./Setup build+  "repl" : tgt : args <- return args+  ghc : rest <- lines `fmap` readFile ("dist/build/autogen/Build_" ++ tgt ++ ".flags")+  let args2 = "--interactive"+                                : "-v"+                                : "-package-db" : "dist/package.conf.inplace"+                                : concatMap words rest ++ args++      args3 = case break (=="--ghc-options") args2 of+                  (a, _:_:b) -> a ++ b+  print args3+  readProcessWithExitCode ghc args3 stdin+#endif
− examples/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 view
@@ -1,13 +1,9 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverlappingInstances#-}-{-# LANGUAGE UndecidableInstances#-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}  {- @@ -17,32 +13,16 @@    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+module MainGhcGeneric1 where  import Datatypes2-import Data.HList.CommonMain -- hiding (HDeleteMany, hDeleteMany)+import Data.HList.CommonMain+import Control.Lens -{--import Data.HList.RecordAdv-import Data.HList.RecordP--}+asProxy :: proxy a -> Proxy a+asProxy _ = Proxy   -- --------------------------------------------------------------------------@@ -108,11 +88,12 @@ 	    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 $ hOccurs $ hBuild 1 ^. from tipHList+  print $ null $ hOccurs $ hBuild [] ^. from tipHList   print (hProject angus :: HList '[Key, Name])  @@ -132,31 +113,21 @@ -- 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.+-- This richer type was needed for making this operation more polymorphic. -- That is, /a)/ would not work without the explicit type,  -- while /b/ would: -- -- >  a)  ((+) (1::Int)) $ snd $ tuple oneTrue -- >  b)  ((+) (1::Int)) $ fst $ tuple oneTrue+--+-- Currently (2014) type signatures are not needed to define tipyTuple. -tuple :: 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)+tuple l = tipyTuple l + -- | A specific tuple -- Need to import an instance of TypeEq to be able to run the examples-oneTrue :: TIP '[Int, Bool]		-- inferred+-- oneTrue :: TIP (TagR [Int, Bool])		-- inferred oneTrue = (1::Int) .*. True .*. emptyTIP  testTuple = do@@ -165,11 +136,10 @@   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+myTipyCow = angus ^. from tipHList  animalKey :: ( SubType l (TIP Animal) -- explicit              , HOccurs Key l          -- implicit@@ -184,7 +154,7 @@   putStrLn "\ntestTIP"   print $ (hOccurs myTipyCow :: Breed)   print $ BSE .*. myTipyCow-  -- print $ hExtend Sheep $ myTipyCow+  -- print $ Sheep .*. myTipyCow   {- if we uncomment the line above, we get the type error      about the violation of the TIP condition: Breed type      occurs twice.@@ -192,7 +162,7 @@     No instance for (Fail * (TypeFound Breed))       arising from a use of `hExtend'   -}-  print $ Sheep .*. tipyDelete (undefined::Proxy Breed) myTipyCow+  print $ Sheep .*. hDeleteAtLabel (Label::Label Breed) myTipyCow   print $ tipyUpdate Sheep myTipyCow  {-@@ -227,7 +197,7 @@   print $ test3   print $ test4   print $ test5-  print $ hProjectByLabels (hLabels (breed `HCons` price `HCons` HNil)) test5+  print $ hProjectByLabels (labelsOf (breed `HCons` price `HCons` HNil)) test5  where   test3 = hDeleteAtLabel breed unpricedAngus   test4 = breed .=. Sheep .@. unpricedAngus@@ -276,13 +246,14 @@  -} -type AnimalCol = [Key,Name,Breed,Price] +type AnimalCol = TagR [Key,Name,Breed,Price]+ testTIC = do   putStrLn "\ntestTIC"   print $ myCol-  print $ (unTIC myCol :: Maybe Breed)-  print $ (unTIC myCol :: Maybe Price)+  print $ (hOccurs myCol :: Maybe Breed)+  print $ (hOccurs myCol :: Maybe Price)  where   myCol = mkTIC Cow :: TIC AnimalCol @@ -290,27 +261,32 @@  myCol = mkTIC Cow :: TIC AnimalCol -*TIC> unTIC myCol :: Maybe Breed+*TIC> hOccurs myCol :: Maybe Breed Just Cow-*TIC> unTIC myCol :: Maybe Price+*TIC> hOccurs myCol :: Maybe Price Nothing *TIC> mkTIC "42" :: TIC AnimalCol Type error ...-*TIC> unTIC myCol :: Maybe String+*TIC> hOccurs myCol :: Maybe String Type error ...  -} -testVariant = (testVar1,(testVar2,(testVar3)))+testVariant = do+    putStrLn "\ntestVariant"+    print testVar1+    print testVar2+    print 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+  testVar2 = testVar1 .!. key+  testVar3 = testVar1 .!. name +animalVar = asProxy $+               key   .=. (undefined :: Integer)+           .*. name  .=. (undefined :: String)+           .*. breed .=. (undefined :: Breed)+           .*. emptyRecord {- -- -------------------------------------------------------------------------- @@ -339,3 +315,4 @@        testTIP        testRecords        testTIC+       testVariant
− 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 view
@@ -4,28 +4,28 @@ Name "Angus" Cow Price 75.5-H[Key 42, Name "Angus", Cow, Price 75.5, 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])+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"]+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[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])+(H[Cow],H[Key 42,Name "Angus",Price 75.5])  testTuple (2,False)@@ -36,9 +36,9 @@  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]+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}@@ -49,6 +49,11 @@ Record{price=8.8,breed=Cow}  testTIC-<Cannot show TIC content!>+TIC{breed=Cow} Just Cow Nothing++testVariant+V{name="angus"}+Nothing+Just "angus"
− examples/MainGhcGeneric2.out 
@@ -1,1 +0,0 @@-(HTrue,HFalse)
examples/MainPatternMatch.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -31,7 +33,7 @@  module Main where -import Data.HList+import Data.HList.CommonMain  makeLabels ["px","py"] @@ -46,7 +48,7 @@ -}  -accessor r f = r # f+accessor r f = r .!. f  -- 1D points point1 x = @@ -62,7 +64,7 @@  -- Record-polymorphic function, which illustrates record pattern-matching, -- with the help of generalized guards-foo p | 0 <- p # px = "X is zero"+foo p | 0 <- p .!. px = "X is zero" foo _ = "something else"  test1  = foo (point1 0)     -- X is zero
− examples/MainPatternMatch.out 
@@ -1,4 +0,0 @@-X is zero-something else-something else-X is zero
examples/MainPosting-040607.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-}@@ -22,7 +23,8 @@  module Main where -import Data.HList+import Data.HList.CommonMain+import Data.Typeable  -- These are your two "implementations".
− examples/MainPosting-040607.out 
@@ -1,1 +0,0 @@-(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False))))
examples/MainPosting-040607.ref view
@@ -1,1 +1,1 @@-(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False))))+(H[MyImplementation1 10,MyImplementation2 20],(True,(True,(False,False))))
− examples/MainPosting-051106.out 
@@ -1,2 +0,0 @@-8-8
+ examples/Properties.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fcontext-stack=100 #-}+{-# 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,139 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module Properties.Common where++import Data.HList.CommonMain+import Test.QuickCheck+import Data.Array.Unboxed+import Data.HList.Variant+import Data.Monoid+import Control.Lens+import Control.Applicative+import GHC.TypeLits (Symbol)+import Language.Haskell.TH++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`++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)+    mappend (BoolN x) (BoolN y) = BoolN (getAll (mappend (All x) (All y)))++instance Arbitrary (Identity (BoolN n)) where+    arbitrary = fmap return arbitrary+++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,67 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+module Properties.KW where+++import Properties.Common+import Test.QuickCheck+import Data.HList.CommonMain+import Test.Hspec+++kwSpecs = describe "kw" $ do+    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' (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,411 @@+{-# 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+++import Data.HList.HSort (hMSortBy)+import Data.HList.Variant (eqVariant)+import Data.HList.Record (hZipRecord2)+import Data.HList.CommonMain+++import Language.Haskell.TH+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 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] ])+                   |]+                ]++          quantify :: TypeQ -> TypeQ+          quantify ty = forallT [ PlainTV (mkName ("x" ++ show i)) | i <- [1 .. n]] (return []) ty+++          rss :: [TypeQ]+          rss = takeK $+                [ [t| (Record :: [*] -> *) $(hListT (map taggedN ns)) |]+                   | ns <- permutations [1 .. fromIntegral n] ]++          -- taggedN 1 == [t| Tagged 1 x1 |]+          taggedN :: Integer -> TypeQ+          taggedN i = [t| Tagged $(litT (numTyLit i)) $(varT (mkName ("x"++show i))) |]++rN n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN (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) (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++#if __GLASGOW_HASKELL__ < 710+ -- XXX doesn't work with ghc-7.10 RC1+  it "hZip/hZip2" $ property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "y")+      return $ hZip x y `eq` hZip2 x y+#endif++  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 "HList monoid unit" $+    property $ do+      x <- genHL (BoolN True :: BoolN "x")+      return $ conjoin+        [ x === (x `mappend` mempty),+          x === (mempty `mappend` x) ]++  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+  -- 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))) |]+            ])+  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)+++  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))+        hM v = hOccursMany xyz === hList2List v+    return $ conjoin+      [ hM x, hM y, hM 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,26 @@+{-# OPTIONS_GHC -fcontext-stack=1000 #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+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 .. 3],+        n2 <- [1 .. 3] ]+    ++ [ noBindS [| describe $(stringE (show (n1,n2,n3))) $(hl3 n1 n2 n3) |]+      | n1 <- [0 .. 2],+        n2 <- [0 .. 1],+        n3 <- [0 .. 2],+        not $ all (==0) [n1,n2,n3] ]+  )
+ examples/Properties/LengthIndependent.hs view
@@ -0,0 +1,635 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+module Properties.LengthIndependent where+import Properties.Common+import Control.Lens+import Data.HList.CommonMain+import Test.Hspec+import Test.QuickCheck+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 "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 "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++    show (map (^. typeIndexed') 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+      return $ conjoin+        [ gread (gshow h) === [(h, "")],+          gread (gshow v) === [(v, "")] ]++  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+          ]++++{- RecordU is disabled for now+  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 "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 :: Label Bool) %~ not),+        -- should work, but it doesn't+        -- 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),+        hCurry (hUncurry id) vx `eq` vx,+        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),+        hCompose (,) id vx vy `eq` (vx,vy) ]+++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 view
@@ -1,3 +1,5 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-}@@ -21,11 +23,15 @@ module TIPTransform where  import Data.HList+import Data.Typeable  -- We start with the examples -newtype MyVal = MyVal Int deriving Show+newtype MyVal = MyVal Int deriving (Show, Typeable) +-- or if no typeable, use+-- instance ShowLabel MyVal where showLabel _ = "MyVal"+ -- A sample TIP tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP -- TIP (HCons (MyVal 20) (HCons 1 (HCons True HNil)))@@ -54,27 +60,7 @@ -- 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+-- part of HList proper now   main = mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4,
− 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 view
@@ -1,6 +1,6 @@-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]+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 view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}@@ -25,12 +26,13 @@  module TIPTransformM where -import Data.HList+import Data.HList.CommonMain+import Data.Typeable import Control.Monad.Identity  -- We start with the examples -newtype MyVal = MyVal Int deriving Show+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,@@ -75,7 +77,7 @@  -- Andrew Frank's test -- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil)))))-tip6 :: IO (TIP (MyVal ': Int ': Bool ': Float ': '[]))+tip6 :: IO (TIP (TagR [MyVal,Int,Bool, Float])) tip6 = ttipM op6 tip1  op6 :: MyVal -> Bool -> IO MyVal@@ -115,38 +117,7 @@ -} -- !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+-- Moved to TIP.hs -- -} -- !TF  main :: IO ()
− 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 view
@@ -1,8 +1,8 @@-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]+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]+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/broken/nn.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_GHC -fcontext-stack=100 #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}++import Data.HList.CommonMain+import Control.Lens+++makeLabelable (unwords [ "r" ++ show n | n <- [0 .. 9 :: Int] ])+r :: RecordU '[Tagged "r0" Int ,+              Tagged "r1" Int,+              Tagged "r2" Int,+              Tagged "r3" Int,+              Tagged "r4" Int,+              Tagged "r5" Int,+              Tagged "r6" Int,+              Tagged "r7" Int,+              Tagged "r8" Int,+              Tagged "r9" Int]+r = [1 .. 10] ^?! listAsHList . from unlabeled . unboxed++++main = print $+  r^.r0 ++  r^.r1 ++  r^.r2 ++  r^.r3 ++  r^.r4 ++  r^.r5 ++  r^.r6 ++  r^.r7 ++  r^.r8 ++  r^.r9
examples/cmdargs.hs view
@@ -1,44 +1,96 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE TemplateHaskell #-} module Main where import System.Console.CmdArgs import Data.HList.CommonMain import Data.Generics-+import Control.Lens+import System.Environment+import GHC.TypeLits (Symbol)+import Data.HList.Labelable(LabeledTo,ToSym)  {- -An example showing off the data instance for Record+An example showing off the data instance for Record / Variant / TIP / TIC  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>-+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  -} -makeLabels6 (words "x y z")+#define USE_LABEL3 __GLASGOW_HASKELL__ == 708 +#if USE_LABEL3+makeLabels3 "examples_cmdargs" (words "x y z tic")+makeLabels3 "optV" (words "optA optB optC")+#else+-- works for ghc-7.6+makeLabels6 (words "x y z tic")+makeLabels6 (words "optA optB optC")+#endif +makeLabelable "abc df"++#if USE_LABEL3+-- XXX remove extra Label?+v = (optA .*. optB .*. optC .*. emptyProxy)+      `zipTagged` (Proxy :: Proxy '[Int,Char,Double])+#else+v = Proxy :: Proxy '[Tagged "optA" Int, Tagged "optB" Char, Tagged "optC" Double]+#endif++type Z' = TagR [Int, Char, Double]+ d0 = x .=. (5 :: Int)     .*. y .=. True-    .*. z .=. False+    .*. 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 E = E { a :: Int, b, c :: Bool }+data Opt = OptA Int | OptB Char | OptC Double     deriving (Show, Data, Typeable)-e0 = E 5 True False +e0 = E 5 True+ main = do     print d0+    print $ gmapT (mkT ((+1) :: Double -> Double)) (mkVariant optC 1 v)+    print $  (mkVariant optC 1 v)+     print $ gmapT (mkT not) d0     print $ gmapT (mkT (+(1::Int))) d0 -    print $ fromConstrB (undefined `extB` (1::Int) `extB` True) undefined `asTypeOf` d0+    let theB :: Typeable a => a+        theB = error "theB"+              `extB` (1::Int)+              `extB` True+              `extB` (2.5::Double)+              `extB` 'b'+              `extB` mkVariant optC theB v+              `extB` mkTIC' (theB :: Char) (Proxy :: Proxy Z') -    rc <- cmdArgs d0-    print rc+    print $ fromConstrB theB undefined `asTypeOf` d0 +    putStrLn "Cmdargs"+    print =<< withArgs ["-a=4", "-b=False" ] (cmdArgs e0)++    -- drop the tic and z fields (which cmdargs doesn't handle)+    let dRec = d0 & from hListRecord %~ (hInit . hInit)+    print =<< withArgs ["-x=4", "-y=False"] (cmdArgs dRec)
− examples/cmdargs.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 view
@@ -1,5 +1,9 @@-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}+Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}+V{optC=2.0}+V{optC=1.0}+Record{x=5,y=False,z=V{optC=1.0},tic=TIC{char='x'}}+Record{x=6,y=True,z=V{optC=1.0},tic=TIC{char='x'}}+Record{x=1,y=True,z=V{optC=2.5},tic=TIC{char='b'}}+Cmdargs+E {a = 4, b = False}+Record{x=4,y=False}
examples/labelable.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds,+  GADTs, ConstraintKinds #-} {- | Demonstrates @hLens'@  may be worthwhile to have a lens-free test suite, doing stuff like:@@ -10,8 +12,16 @@ import Data.HList.CommonMain import Control.Lens +import Text.Read+ makeLabelable "x y" +#if __GLASGOW_HASKELL__ < 707+#define INT_SIG_76 :: Int+#else+#define INT_SIG_76+#endif+ r = x .==. "hi" .*.     y .==. (y .==. 321 .*. x .==. 123 .*. emptyRecord) .*.     emptyRecord@@ -20,5 +30,18 @@     print (r ^. x)     print (r & x .~ ()) -    print (r ^. y . y)+    -- ghc-7.6 doesn't default when r is involved lower down,+    -- while 7.8.2 does+    print (r ^. y . y  INT_SIG_76)+    print (r ^. y . x  INT_SIG_76)+     print (r & y . y .~ "xy")++    putStrLn "\nread-show"+    print (readMaybe (show r) `asTypeOf` Just r)+    print (readMaybe "Record{x=\"hi\",y=Record{y=321,x=123}}" `asTypeOf` Just r)++    -- there is no permuting of labels+    print (readMaybe "Record{y=Record{y=321,x=123},x=\"hi\"}" `asTypeOf` Just r)++    print $ (r ^. rearranged) `asTypeOf` (undefined :: Record '[Tagged "y" t, Tagged "x" s])
− examples/labelable.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 view
@@ -1,4 +1,11 @@ "hi" Record{x=(),y=Record{y=321,x=123}} 321+123 Record{x="hi",y=Record{y="xy",x=123}}++read-show+Just Record{x="hi",y=Record{y=321,x=123}}+Just Record{x="hi",y=Record{y=321,x=123}}+Nothing+Record{y=Record{y=321,x=123},x="hi"}
examples/lens.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds #-} {- | Demonstrates @hLens@. See also labelable.hs which is more "convenient" @@ -6,12 +8,26 @@ import Data.HList.CommonMain import Control.Lens -makeLabels6 (words "x y")+makeLabels6 (words "x y z") ++#if __GLASGOW_HASKELL__ > 707+yRec = y .=. 321 .*. x .=. 123 .*. emptyRecord+#else+-- defaulting doesn't work in ghc-7.6.3+yRec = y .=. (321 :: Integer) .*. x .=. (123 :: Integer) .*. emptyRecord+#endif+ r = x .=. "hi" .*.-    y .=. (y .=. 321 .*. x .=. 123 .*. emptyRecord) .*.+    y .=. yRec .*.     emptyRecord ++_ = (r^.y') `asTypeOf` hRearrange'+    (x .=. 1 .*. y .=. 1 .*. emptyRecord)++rSmall = x .=. "" .*. emptyRecord+ x' a = hLens x a y' a = hLens y a @@ -32,3 +48,15 @@     print (r ^. y' . y')     print (r & y' . y' .~ "xy") +    putStrLn "\n\nIsos"+    print (r & sameLength . unlabeled . hTuple . _1 .~ ())+    print (r & sameLength . unlabeled . hTuple . _2 .~ ())+    print (z .=. () .*. r+              & unlabeled' . from tipHList %~ ttip (\x z -> x ++ show (z :: ())))++    r ^. unlabeled . from tipHList & tipPutStrLn+++tipPutStrLn tip = ttipM ?? tip $ \x -> do+  putStrLn x+  return x
− examples/lens.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 view
@@ -9,3 +9,11 @@ Record{x=(),y=Record{y=321,x=123}} 321 Record{x="hi",y=Record{y="xy",x=123}}+++Isos+Record{x=(),y=Record{y=321,x=123}}+Record{x="hi",y=()}+Record{z=(),x="hi()",y=Record{y=321,x=123}}+hi+TIPH["hi",Record{y=321,x=123}]
+ examples/prism.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-} -- for pun+{-# LANGUAGE TemplateHaskell #-}+module Main where+import Data.HList.CommonMain+import Data.HList.Labelable (hLens')+import Control.Lens++-- generate left = Label :: Label "left"+makeLabels6 (words "left right up down")++--- define the Labelable labels manually+left_ = hLens' left+right_ = hLens' right+up_ = hLens' up+down_ = hLens' down++-- this definition is needed to decide what order+-- to put the fields in, as well as their initial types+r = [pun|right left up|] where+  left = 'a'+  right = 2 :: Int+  up = 2.3 :: Double++v = mkVariant left 'x' r++main = do+    putStrLn "Lookup and set"+    inspectV++    putStrLn "\nrepeat with Labelable"+    inspectV_++    putStrLn "\nSetting the missing tag does nothing:"+    print $ set right_ () v+    Left 'x' <- set _Right () (Left 'x') -- prisms for Either do the same thing+                & return++    putStrLn "\nLenses compose:"+    Nothing  <- v3 ^? up_.up_ & return+    Just 'x' <- v3 ^? left_ & return+    v4 ^? left_.left_ & print++    putStrLn "\nLenses+prisms compose:"+    inspectRV++    putStrLn "\n\"extension\""+    extensionTests++    putStrLn "\nInternal Structure:"+    putStrLn $ indent $ show vs++++lazyX = mkVariant (Label :: Label "x") 'a' lazyProto+lazyY = mkVariant (Label :: Label "y") (2.5 :: Double) lazyProto++lazyProto = undefined :: Record+  '[Tagged "x" x, Tagged "y" y]++vs = [pun| v v2 v2' v3 v4 v5 v6 v7 |]++inspectV = do+    v ^? hPrism left & print+    v ^? hPrism right & print+    v ^? hPrism up & print+    v2 ^? hPrism left & print++-- note that we can change the type of the 'x' field+-- from Char to ()+v2 = set (hPrism left) () v++inspectV_ = do+    v ^? left_ & print+    v ^? right_ & print+    v ^? up_ & print+    v2' ^? left_ & print+++inspectRV = do+    r2 ^? down_.left_ & print+    r2 ^? down_.right_ & print+    r2 ^? du & print++du = down_.up_++r2 = down_ .==. v .*. r+++-- or with the "better" label+v2' = set left_ () v+++v3 = v & up_ .~ v & up_.up_ .~ "upup"+v4 = v & left_ .~ v & left_.left_ .~ "leftleft"+++extensionTests = do+    Just "hi" <- v5 ^? down_ & return+    Just "hi" <- v6 ^? down_ & return+    Nothing   <- v7 ^? down_ & return+    Just 'x'  <- v7 ^? left_ & return+    return ()+++v5 = down .=. Just "hi" .*. v+v6 = down_ .==. Just "hi" .*. v+v7 = down .=. (Nothing :: Maybe String) .*. v++-- start a newline after every } to make the results readable+indent :: String -> String+indent xs = indent' 0 xs++indent' n xs | n < 0 = indent' 0 xs+indent' n ('}' : xs) = "}\n" ++ replicate n ' ' ++ indent' (n-4) xs+indent' n ('{' : xs) = '{' : indent' (n+4) xs+indent' n (x : xs) = x : indent' n xs+indent' _ [] = []
+ examples/prism.ref view
@@ -0,0 +1,37 @@+Lookup and set+Just 'x'+Nothing+Nothing+Just ()++repeat with Labelable+Just 'x'+Nothing+Nothing+Just ()++Setting the missing tag does nothing:+V{left='x'}++Lenses compose:+Just "leftleft"++Lenses+prisms compose:+Just 'x'+Nothing+Nothing++"extension"++Internal Structure:+Record{v=V{left='x'}+        ,v2=V{left=()}+        ,v2'=V{left=()}+        ,v3=V{left='x'}+        ,v4=V{left=V{left="leftleft"}+            }+        ,v5=V{down="hi"}+        ,v6=V{down="hi"}+        ,v7=V{left='x'}+        }+
examples/pun.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}
− 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 view
@@ -4,6 +4,6 @@ 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",c="c",b=Record{a=3}}}+Record{r=Record{c=1,y="hi",b=Record{a=3}}} Record{r=Record{x=1,y="hi"}}
examples/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 view
@@ -1,10 +1,11 @@ module Main where +import Cabal import Control.Exception import System.FilePath import Test.Hspec-import System.Process import System.Exit+import System.Process import System.Directory import Data.Maybe import Control.Monad@@ -28,17 +29,24 @@     let ex = ("examples" </>)     let inFile = ex (takeBaseName f)         outFile = dropExtension inFile ++ ".out"+        errFile = dropExtension inFile ++ ".err"         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")+    (ec, stdout, stderr) <- cabal+            ["repl","examples",+              "-v0", "--ghc-options", "-w -fcontext-stack=50 -iexamples -v0"]+              (":set -i\n:set -iexamples\n:load " ++ inFile ++ "\nmain")      writeFile outFile stdout      ofe <- doesFileExist refFile-    diff <- if ofe then fmap Just $-        readProcess "diff" ["-b", outFile, refFile] "" else return Nothing+    diff <- if ofe+      then fmap Just $+        readProcess "diff" ["-b", outFile, refFile] ""+          `finally` writeFile errFile stderr+      else return Nothing++    unless (diff == Just "") $ writeFile errFile stderr      return (ec, stderr, diff)  `shouldReturn` (ExitSuccess, "", Just "")