packages feed

HList 0.2.3 → 0.5.4.0

raw patch · 97 files changed

Files

+ ChangeLog view
@@ -0,0 +1,459 @@+20 Feb 2025+0.5.4 Release+Merge Daniil's Itskov's changes:+	Add files for building with nix+	Build with ghc-9.10.1+Remove tests for hCurry and hCompose where ghc-9.4.8 has poor type inference+not seen in newer versions.++23 Sep 2023+0.5.3 Release+Build with ghc-9.4.6 and ghc-9.6.1.+ghc-9.4.6 cannot compile examples/Properties/LengthIndependent.hs+as some types cannot be inferred. This is fixed in ghc-9.6.1.++18 Feb 2022+0.5.2 Release+Remove custom Setup.lhs which was for ghc-7.6++Change to pun quasiquote improves error messages:+  For `f [pun| x y |] = ()`+  f :: _ => r (a ': b ': c) -> ()  -- old+  f :: _ => r as -> ()             -- new+Previously if you supplied a 9 element record to a function+needing 10 elements, the error would not name the missing field.+It is possible but unlikely that the old code will need to a type+annotation like+(id :: HLengthGE x (HSucc (HSucc HZero)) => r x -> r x)++23 Oct 2021+0.5.1 Release+Build & pass tests with ghc-8.4.4 through 9.2.0.20210821,+though with 9.2.0.20210821 dependencies for tests need+cabal flags --allow-newer=base --allow-newer=template-haskell,+and also invariant-functors and lens from git (as specified in `cabal.project`)++Add examples/HListExample/OverloadedLabels.hs++19 Feb 2018+0.5.0 Release+Build & pass tests with ghc-7.6 through 8.4.0.20180209++Add Dredge.hs (ghc>=7.8): access nested records/variants given only the last+label along a path++Move toLabel to another class to allow it to return Labels with+kinds other than Symbol.++tipyLens can now change the element type++Add hTake and hDrop++Use TypeError for prettier error messages in ghc-8.0 (still backwards+compatible)++Improve HFind and HUpdateAtHNat error messages by mentioning the whole+record being changed++22 Dec 2015+0.4.2 Release++Depend on base-orphans to avoid multiple definitions of Typeable '[],+Typeable '(:)++3 Aug 2015+0.4.1 Release++Add RecordU.hs, a record type with elements stored in unboxed arrays++Documentation fixes (Thor Michael Støre)++5 May 2015+0.4 Release++16 Apr 2015+Make tests run (and pass) when called by "runghc Setup test"++Add hNot, and add HNotFD which is injective (unlike the type family)++Replace uses of `HLength xs ~ n` with `HLengthEq xs n`.++15 Mar 2015+Add HCurry.hs.++Redefine Arity such that `Arity f (HSucc HZero)` will refine the+type of `f` to `x -> y`.++SameLabels is generalized so that functions like 'asLabelsOf' do+not need to explicitly convert a that specifies the ordering of+labels. Additional constraints might be needed to restore the old+behavior:++> type SameLabelsOld x y = (HAllTaggedLV x, HAllTaggedLV y, SameLabels x y)++Similarly HExtend instances Proxy intended for making Proxies+used to disambiguate labels (see 'asLabelsOf' again).++Add hMapOutV, zipVR, extendsVariant. Rename the previous+splitVariant to splitVariant1, and use the name splitVariant for+a function that splits a Variant into two Variants.++Add projected to Labelable.hs which allows working on a smaller+Record or Variant.++Add HasFieldM for lookups that return a default value if the+field is missing.++Split HZip into two classes: class HUnzip r x y xy => HZip r x y xy.+This allows instance HUnzip Variant x y xy.++Add Data,Typeable,Enum,Bounded,Ord,Monoid instances for Variant and TIC++Implement HRLabelSet in terms of HLabelSet, which simplifies+inferred types that would otherwise have redundancy (HLabelSet+(LabelsOf r), HRLabelSet r)++Move definitions into FakePrelude, and split up+examples/Properties.hs into separate modules to help with+compilation times when adding new tests.++15 Feb 2015+Change HList to a data family (see comments in HList.hs).++Change the Show instance for TIP and HList to use "," not ", " as the+separator for consistency with Record and ordinary lists.++Parameterize HZip over the collection type to work on Record, TIP as well as+HList.++Add and use HProxies for building the spine of a HList from the type, to avoid+having HLists of undefined/error values somewhere.++Build with ghc-7.10 RC1. RecordU/RecordUS is moved to broken/ instead of+updating it.++9 Sep 2014+Change the ordering of the list produced by HLeftUnion / (.<++.)+to better match hAppend / ++ suggested by the name.++25 Aug 2014+Add HSort, which provides a merge sort and a quick sort.++Support _ (wildcard) with the pun quasiquoter, and make+patterns such as [pun| x y _ |] constrain the Record or Variant+to have at least 3 elements.++Reduce the number of parameters for Labelable++Allow operations with different label kinds (ie.+Record [Tagged 1 x, Tagged "y" Int]) to proceed as expected.++13 Jul 2014+Start RecordU and RecordUS, a variation on Record where the values+are stored in unboxed array(s).++Add Partition, GroupBy and Span.++Add list2HList and isos sameLength and sameLabels.++23 Jun 2014+TIPTransform and TIPTransformM become part of the distribution,+and missing fields are reported with the Fail superclass+technique.++Projection of a TIP to a tuple is reimplemented without an explicit+type signature. The functions are exported as tipyTuple,+tipyTuple3 etc.++Conversion between HLists and up to 6-tuples done with HTuple.++Add ZipVariant, Unvariant, splitVariant, extendVariant,+an instance Eq (Variant v) and an instance Labelable TIC.++Add quickcheck in examples/Properties.hs. Coverage measured with+HPC is about 40%.++5 Jun 2014+Start to parameterize operations on the collection type. This+means that where we previously had HMapCxt f x y another+type parameter with kind [*] -> * is added. This means+previous uses of HMapCxt f x y become HMap HList f x y.+This allows hMap to be used with Record and Variant.+HUpdateAtLabel is similarly generalized.++Rework Variant: the implementation is now similar to Dynamic+and TIC. Likewise, TIP is implemented in terms of Record.++28 May 2014+Add tipyLens and ticPrism.++Add a HExtend instance for Variant.++Add functional dependencies to Labelable (and corresponding+superclasses) to avoid ambiguous types.++26 May 2014+Add prisms for Variant. This adds a dependency on "profunctors".++Parameterize Labelable on the collection type. This allows+labelable labels to be used with RecordS or VariantS, where+the resulting Optic is a Lens or Prism respectively.++Remove recordLabels in favor of labelsOf: a kind variable which+only appears on the RHS required a lengthy type annotation to fix+that variable. Pattern matching to convert a `Label (a :: k)` to+`a :: k` happens later on when another value with kind `k` is a+available on the LHS.++Improve type errors when accessing missing fields when using+Labelable labels. Except for HPrism, the error message contains+`Fail (FieldNotFound "x")`. This involved adding a HUpdateAtLabel+class and HTPupdateAtLabel type which hides the `n` type+variable.++Reduce the number of parameters to HMapCxt. The old version could+be defined in terms of the new version as:++	type HMapCxt_old f a b ha hb = (HMapCxt f a b,+																	HList a ~ ha,+																	HList b ~ hb)++Reimplement RecordValues in terms of HMap. The original+implementation is kept because it avoids the need for+-XAllowAmbiguousTypes.++Add hMapR and hMapV to map over the values in a Record or the+value in a Variant respectively. These functions are defined in+terms of HFmap which may be useful on it's own.++Add a typeable instance for Label3, and change examples/cmdargs.hs+to use this label kind. This allows the example to work with+ghc-7.8.2 which lacks an instance Typeable (x :: Symbol).++28 Mar 2014+	Release 0.3.4.1+	Fix build with ghc-7.8 broken by changes in HList 0.3.4++20 Feb 2014+	Release 0.3.4+	RecordPuns add ( ) syntax+	Use the tagged package: this removes LVPair and lowercase proxy.++03 Feb 2014+    Release 0.3.2.0+	Relax hspec dependency++29 Jan 2014+	Release 0.3.1.0+	Work with newer GHC.TypeLits (SingI and similar were moved out)++05 Nov 2013+	Release 0.3.0.1+	fix `cabal test'++01 Nov 2013+	Release 0.3+	pun quasiquote supports nested records+	remove HStagedEq++30 Oct 2013+	Another large patch from Adam Vogt+	Connect HList with Lens. The Data instance for HList+	treats HList as a list; a Data instance for HListFlat+	treats HList as a tuple.++24 Oct 2013+	Another large patch from Adam Vogt+	Added HFoldl, HScanr, Data instances for HList, finished the+	update of Record, the Keyword example+	becomes full-fledged part of HList++17 Sep 2013+	Another large patch from Adam Vogt+	Added HReplicate, SameLength constraint (used by HSequence and HMap),+	FunCxt for interpreting context applications,+	convenient syntax for record patterns,+	clean-up of ApplyAB and general clean-up++31 Aug 2013+	Large patch from Adam Vogt+	 Improving the Apply class (ApplyAB) to help type inference+	 and avoid specifying many type sigatures.+	 Fix a few of broken code files, in particular RecordAdv.++28 Aug 2013+	Large patch from Adam Vogt+	 moved files that need attention to broken/+	 put HSequence in with HList.HList: fixed the function+	 added Label6 with GHC Symbols+	 fix HZip, Variant, examples/TIPTransformM.hs+	 Many Haddoc changes and beautifications+	 format some examples for doctest++27 Aug 2013+	Adam Vogt's patch greatly simplifying makeLabels.+	Updated TIC.hs++15 Nov 2012+	Ported basic Records.++31 Oct 2012+	New file HList/HList.hs contains the implementation of+	heterogeneous lists. HListPrelude.hs defines operations+	that work across all heterogeneous collections (lists, TIP,+	Records, etc).+	General clean-up, removing obsolete code.+	Code re-written up to Records.++25 Oct 2012+	hUnfold+	hProjectByHNats and hProjectAwayByHNats now take type-level+	list of naturals as the argument. They are implemented in terms+	of Unfold. More computation is made purely type-level.++24 Oct 2012+	Nat, Bool and [*] kinds+	HList is now GADT+	Rewriting FakePrelude, HListPrelude, HArray using type families+	to a large extent, and getting rid of functional dependencies+++12 Oct 2011+	Getting rid of overlapping instances in HOccurs+	Using only one TypeEq. This is the only place with overlapping instances+	Using ~ operator instead of TypeCast. Deprecating TypeCast+	Rearrangements of code, removing obsolete code+	Making sure everything works under GHC 7.0.4+++19 May 2010+	Beautification, release and tag 0.2.3 by Adam Vogt++26 April 2010+	Patches from Adam Vogt to format documentation for Haddoc and+	to expose MakeLabels+	Release 0.2.1 by Gwern Branwen++29 March 2010+	examples/TIPTransformM.hs, the monadic version of+	TIPTransform.hs++17 February 2010+	Two patches from Adam Vogt to get the code compile on ghc-6.12+	and to make Record Typeable instances nonstrict++10-14 January 2010+        Reverse parameter order for .@.+	Changed fixity <+++	Pushed uses of LANGUAGE pragmas further for OOHaskell examples++16 September 2009+	Added TypeCastGeneric3, TypeEqGeneric3 -- the instances of+	typeCast and TypeEq that don't require separate compilation.+	They are like TypeCastGeneric2, TypeEqGeneric2, but integrated+	with the FakePrelude.+	Added the example file TIPTransform.hs, a variation on the+	keyword argument problem posed by Andrew U. Frank.+	Adjusted the LANGUAGE pragmas, made the examples run without+	the global -fglasgow-exts++15 September 2009+	Release 0.2 by Gwern Branwen++11 August 2009+	Made the regression tests run again.+	Please do "cd examples; make test-ghc"+	after any changes.+	+11 August 2009+	Applied a patch from Justin Bailey:+	Updated fixity declarations for record operators for+	usability and to better match familiar list and +	arithmetic operators.+	Added Haddock comments for these operators++1 July 2009+	Applied a set of four patches by Brian Bloniarz:+	Improve error messages from Record functions using the Fail+	type class trick+	Add hRearrange, to permute a Record by labels+	Expose a few hidden modules, needed for HaskellDB+	Make hMap, hMapOut & recordLabels maximally lazy+	Add recordValues, analogous to recordLabels+	+29 June 2008+	Apply the set of patches by gwern0@gmail.com: moving a few+	files around, cleaning up hlist.cabal+	+3 February 2008+	Fifteen patches by gwern0@gmail.com: Data.HList hierarchy,+	use of LANGUAGE, -Wall, changes to Cabal files+	+19 September 2007+	Added HMemberM+	Optimized record projection in Record.hs. The optimization+	should be especially noticeable for record narrowing.+	Added NarrowM, which reports both success and failure of narrowing+	Added equivR, record equivalence modulo field order, with+	witnessing conversions+	ConsUnion.hs now checks for record types and treat the latter+	equivalent modulo the order of fields. This gives optimized,+	shallower unions.+	+13 September 2007+	Added UnionSymRec, the symmetric union of two records. The code+	is not very optimal though.+  +12 September 2007+	Added MakeLabels -- Template Haskell code for automatically+	generating Labels (as in Label4.hs).+	Renaming of (data) types in Records, to more meaningful names.+	+05 September 2007+	Added ConsUnion.hs -- building homogeneous lists of heterogeneous+	components by constructing the union on-the-fly.+	+12 February 2007+	Added patches by Einar Karttunen:+	Move files to subdirectories+	Add Cabal infrastructure and HList.hs+	Make it compile with GHC 6.6+	+31 October 2006+	Added HSequence.hs: (monadic) `sequence' for heterogeneous lists.+	It is also the illustration of TypeCast.+	+26 October 2006+	Added CHList.hs: Potentially infinite, open, statically+	constrained HLists.+	+30 August 2006+	Record.hs: Labels now are exclusively type-level entities with no+	run-time representation. The Record API remains the same (although+	the implementation had to be adjusted).+	+31 July	2006+	TAG Release-2.0. The HList DARCS repository announced.+	+22 June	2006+	VariantP.hs: Our extensible (variant) list supports the regular+	list API.+	+20 June	2006+	Added VariantP.hs -- polymorphic variants as dual of records.+	The extensibility problem solved? We can re-use as much as old+	code as possible, when extending the variant and extending+	the functions to the extended variant (and get the subtyping for+	free).+	+19 June	2006+	Added RecordP.hs -- records with unzipped and fully phantom+	labels. Added tests as well.+	+08 May	2006+	MainPatternMatch.hs -- example of pattern-matching on HList's+	Records+	+08 February 2006+	Primed hMap/HMap as to enable a new native definition+	Started ChangeLog, finally.
Data/HList.hs view
@@ -13,16 +13,13 @@ module Data.HList (   module Data.HList.CommonMain,- module Data.HList.GhcSyntax,- module Data.HList.GhcRecord,- module Data.HList.GhcExperiments,+ -- module Data.HList.RecordAdv,  module Data.STRef,  module Data.IORef,  module Data.Typeable,  module Control.Monad,  module Control.Monad.ST,  module Control.Monad.Fix,--- module GHC.IOBase, -- module DeepNarrow, -- module Nominal, -- module New,@@ -34,13 +31,9 @@  import Data.HList.CommonMain hiding ( HDeleteMany                          , hDeleteMany-                         , TypeCast-                         , typeCast                          ) -import Data.HList.GhcSyntax-import Data.HList.GhcRecord-import Data.HList.GhcExperiments+-- import Data.HList.RecordAdv  import Data.STRef import Data.IORef@@ -48,13 +41,14 @@ import Control.Monad import Control.Monad.ST import Control.Monad.Fix---import GHC.IOBase hiding (stToIO, writeIORef, readIORef, newIORef, IORef,unsafeIOToST,unsafeSTToIO)  infixr 9 #-(#) :: (HasField l r v) => r -> l -> v+(#) :: HasField l r v => r -> Label l -> v m # field = (m .!. field)  concrete :: (MonadFix m) => (a -> m a) -> a -> m a concrete generator self = generator self  where   _ = mfix generator++
Data/HList/CommonMain.hs view
@@ -1,27 +1,236 @@ {- | -   The HList library+   Description : import me+   Copyright   : (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke -   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke+   The HList library -   This is a next-to-main module that loads all modules that at least-   *compile* fine for all the models of interest. See the Makefile-   for ways to run different models.+   This module re-exports everything needed to use HList.  -}  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- , module Data.HList.TIP- , module Data.HList.TIC- , module Data.HList.HZip++ -- * Record  , module Data.HList.Record- , module Data.HList.Variant+ -- | quasiquoter 'pun' helps to avoid needing a proxy value with+ -- type 'Label' in the first place: when you take values out of or into+ -- records with pattern matching, the variable name determines the label+ -- name.+ , module Data.HList.RecordPuns++ -- ** Unpacked / Unboxed Records+ , RecordU+ , RecordUS+ , SortForRecordUS(..)+ , HUpdateMany(..)+ , hMapRU++ -- *** internals for types+ , HFindMany, HNats2Integrals(..)++ , RecordUSCxt+ , HLookupByHNatUS, HLookupByHNatUS1+ , HSubtract, HMapUnboxF, UnboxF+ , BoxF, EqTagValue, GetElemTy, ElemTyEq+ , RecordToRecordU, RecordUToRecord++ -- * HList+ -- | A subset of "Data.HList.HList" is re-exported.+ , module Data.HList.HList+ , module Data.HList.HZip+ -- ** A subset of "Data.HList.HSort"+ , hSort+ , HSort+ , HSortBy(..)+ , HLeFn, HDown+ , HSet, HSetBy+ , HIsSet, HIsSetBy+ , HAscList, HIsAscList++ -- ** A subset of "Data.HList.HCurry"+ , HCurry'(..)+ , hCurry, hUncurry+ , hCompose++ -- * TIP+ -- | Public interface of "Data.HList.TIP"+ , TIP+ , emptyTIP+ , tipyUpdate+ , tipyLens+ , tipyLens'+ -- ** projection+ , tipyProject+ , tipyProject2+ , tipyTuple+ , tipyTuple3+ , tipyTuple4+ , tipyTuple5+ , TagUntag, TagUntagFD(..)+ , TagR++ -- ** TIP transform+ , TransTIP(..)+ , TransTIPM(..)++ -- * TIC+ -- | Public interface of "Data.HList.TIC"+ , TIC+ -- ** creating TIC+ , mkTIC+ , mkTIC1+ , mkTIC'++ -- ** get,set,modify+ , ticPrism, ticPrism'++ -- * Variant+ -- | Public interface of "Data.HList.Variant"+ , Variant+ , mkVariant+ , mkVariant1+ , castVariant+ , HMapV(..), hMapV+ , hMapOutV+ , ZipVariant(..)+ , ZipVR(..), zipVR+ -- ** projection+ -- *** many+ , SplitVariant(splitVariant)+ , ProjectVariant(..)+ , ExtendsVariant(..)+ , ProjectExtendVariant(..)+ -- *** one+ , HPrism(..)+ , unvarianted, unvarianted'++ , splitVariant1+ , splitVariant1'+ , extendVariant+ -- **** implementation+ , Unvariant(..)+ , Unvariant'(..)++++ -- * Conversions between collections+ -- $convention the foo' optic has the same type as+ -- @Control.Lens.simple . foo . Control.Lens.simple@.+ -- 'hLens'' is an exception to this rule.++ , TypeIndexed(..)+ , typeIndexed'+ -- ** HList and Record+ -- | 'unlabeled' 'unlabeled''++ -- ** HList and TIP+ , tipHList, tipHList'+ -- ** Record and RecordU+ , unboxed, unboxed'+ -- ** Record and RecordUS+ , unboxedS, unboxedS'+ -- ** Record and Variant+ , hMaybied, hMaybied'++ -- ** Newtype wrappers+ -- $convention these isos unwrap/wrap the newtypes 'TIP' 'TIC' and+ -- 'Record'. Names follow the pattern @fromTo :: Iso' From To@.++ -- | 'hListRecord' 'hListRecord'' are exported under "Data.HList.Record"+ , ticVariant, ticVariant'+ , tipRecord, tipRecord'++ -- *** implementation+ , VariantToHMaybied(variantToHMaybied)+ , HMaybiedToVariantFs+ , hMaybiedToVariants++ -- * "Data.HList.Keyword"+ -- | the \"public\" parts. More examples are in the module documentation.+ , Kw(..), recToKW, IsKeyFN, K,  ErrReqdArgNotFound,  ErrUnexpectedKW++ -- * Labels+ {- | By labels, we mean either the first argument to 'Tagged' (in the+   type-level lists that are supplied to 'Record', 'RecordU', 'TIP', 'TIC'),+   or the expressions used to specify those types to be able to look up+   the correct value in those collections.++   Nearly all types can be labels. For example:++   @+     r :: Record '[Tagged "x" Int,   -- kind GHC.TypeLits.Symbol +                   Tagged () (),    -- see "Data.HList.Label5"+                   Tagged (Lbl HZero LabelUniverse LabelMember1) () -- Label3+                  ]+     r = 'hBuild' 8 () () -- don't need to use '.=.' / '.==.' and '.*.'+                           -- if we have a type signature above+   @+ +    we could define these variables++   @+    xLabel = Label :: Label \"x\" -- 'makeLabels6' ["x"] would define x with the same RHS+    xLens  = hLens' xLabel        -- 'makeLabelable' "x" would define x with the same RHS+   @++   to access the @8@ given above:++   @+    r '.!.' xLabel+    r  ^.   xLens   -- alternatively Control.Lens.view+    r  ^. `x        -- with HListPP is used (not in ghci),+                    -- which avoids the issue of conflicting+                    -- definitions of x, which mean the same+                    -- thing+   @++ -}+ -- $label6demo++ , module Data.HList.Labelable+ -- $labelable++ -- ** "Data.HList.Dredge"+ -- *** lenses+ , dredge, dredge'+ , dredgeND, dredgeND'+ , dredgeTI'+ -- *** plain lookup+ , hLookupByLabelDredge, HasFieldPath++ -- ** namespaced labels+ , module Data.HList.Label3++ -- ** labels as any instance of Typeable+ --  | "Data.HList.Label5"++ -- ** template haskell+ , module Data.HList.MakeLabels+++ -- * "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@@ -29,8 +238,94 @@ import Data.HList.HArray import Data.HList.HOccurs import Data.HList.HTypeIndexed+import Data.HList.Record+-- 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 hiding (IsKeyFN) import Data.HList.TIP import Data.HList.TIC+ import Data.HList.HZip-import Data.HList.Record+import Data.HList.Label3 hiding (MapLabel)+import Data.HList.Label5 () -- only instances+import Data.HList.Label6 () -- only instances+import Data.HList.Labelable (Labelable(..),+                             Projected(..), projected',+                             toLabel,+                             (.==.),+                             LabeledOptic)+ import Data.HList.Variant++import Data.HList.Data () -- only instances++import Data.HList.Keyword+import Data.HList.RecordPuns+import Data.HList.RecordU++import Data.HList.Dredge++{- $label6demo #label6demo#++ Instances from "Data.HList.Label6"++>>> :set -XDataKinds+>>> (Label :: Label "x") .=. (5::Int) .*. emptyRecord+Record{x=5}++>>> let x = Label :: Label "x"+>>> let r = x .=. (5::Int) .*. emptyRecord+>>> r .!. x+5++-}++{- $labelable #labelabledemo#++Rather than having the @x = Label :: Label \"x\"@, the labels+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:++>>> let r = (Label :: Label "x") .=. "5" .*. emptyRecord++The Labelable way:++>>> let r2 = x .==. "5" .*. emptyRecord++>>> r ^. x+"5"++>>> r2 ^. x+"5"++>>> 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
@@ -0,0 +1,336 @@+{-# LANGUAGE CPP #-}++{- | 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 with promoted+string (Symbol) labels because of+<https://ghc.haskell.org/trac/ghc/ticket/9111>++[@HList@]++The data instance for++> a :: HList '[Int, Double, b]++Looks like the same instance for++> type T b = (Int, (Double, (b, ())))+++[@HListFlat@]++The Data instance for++> a :: Data b => HListFlat '[Int,Double,b]++will look like the Data instance for:++> data A b = A Int Double b+++[@Record@]++For 'Record' similar ideas apply. An++> a :: Record '[ LVPair "x" Int, LVPair "y" Double ]++should behave like a:++> data A = A { x :: Int, y :: Double } deriving (Data)++Many unsafecoerces are necessary here because the Data class includes type+parameters @c@ that cannot be used in the class context for the instance.+Perhaps there is another way.++-}+module Data.HList.Data (+    -- * exports for type signatures/ haddock usage+    DataHListFlatCxt,+    DataRecordCxt,+    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 Data.HList.Variant+import Data.Data+import Data.HList.TIC+import Data.HList.TIP++-- for Typeable '[] and Typeable '(:) with ghc-7.6+import Data.Orphans ()++#if OLD_TYPEABLE+import Data.List+#endif++import Unsafe.Coerce+++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))++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 na g a = (+        g ~ FoldRArrow a (HList a),+        HBuild' '[] g,+        Typeable (HListFlat a),+        TypeablePolyK a,+        HFoldl (GfoldlK  C) (C g) a (C (HList a)),++        HFoldr+            (GunfoldK C)+            (C g)+            (HReplicateR na ())+            (C (HList a)),++        HLengthEq a na,+        HReplicate na ())+++-- | ghc-8.0.2 can't work out the type g,+-- in the 2nd argument of gfoldl. ghc <= 7.10+-- don't need it.+--+-- in `instance Data (HListFlat '[a,b,c])`+--+-- > g ~ (a -> b -> c -> HList '[a,b,c])+-- > g ~ GetG '[a,b,c] (HList '[a,b,c])+type family FoldRArrow (xs :: [*]) (r :: *)++type instance FoldRArrow '[] r = r+type instance FoldRArrow (x ': xs) r = x -> FoldRArrow xs r +++instance DataHListFlatCxt na g a => Data (HListFlat a) where+    gfoldl k z (HListFlat xs) = c3 $+                    hFoldl+                        (c1 (GfoldlK k))+                        (c2 (z hBuild))+                        xs+        where+              c1 :: forall c. GfoldlK c -> GfoldlK C+              c1 = unsafeCoerce++              c2 :: forall c. c g -> C g+              c2 = unsafeCoerce++              c3 :: forall c. C (HList a) -> c (HListFlat a)+              c3 = unsafeCoerce++    gunfold k z _ =+              c3 $ withSelf $ \self ->+                hFoldr+                    (c1 (GunfoldK k))+                    (c2 (z hBuild))+                    (hReplicate (hLength self) ())+        where+              withSelf :: forall t c. (t -> c t) -> c t+              withSelf x = x undefined++              c1 :: forall c. GunfoldK c -> GunfoldK C+              c1 = unsafeCoerce++              c2 :: forall c. c g -> C g+              c2 = unsafeCoerce++              c3 :: forall c. C (HList a) -> c (HListFlat a)+              c3 = unsafeCoerce++    dataTypeOf _ = hListFlatDataRep+    toConstr _   = hListFlatConRep++hListFlatDataRep = mkDataType "Data.HList.HList" [hListFlatConRep]+hListFlatConRep = mkConstr hListFlatDataRep "HListFlat" [] Prefix++type DataRecordCxt a =+    (Data (HListFlat (RecordValuesR a)),+            TypeablePolyK a,+            TypeRepsList (Record a),+            RecordValues a,+            RecordLabelsStr a)++instance DataRecordCxt a => Data (Record a) where+    gfoldl k z xs = c1 (gfoldl k z (HListFlat (recordValues xs)))+        where+            c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a)+            c1 = unsafeCoerce++    gunfold k z con = c1 (gunfold k z con)+        where+            -- LVPair and Record are newtypes, so this should be safe...+            c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a)+            c1 = unsafeCoerce++    dataTypeOf x = snd (recordReps (recordLabelsStr x))+    toConstr x = fst (recordReps (recordLabelsStr x))+++recordReps fields =+    let c = mkConstr d "Record" fields Prefix+        d = mkDataType "Data.HList.Record" [c]+    in (c,d)++++class RecordLabelsStr (xs :: [*]) where+    recordLabelsStr :: Record xs -> [String]++instance RecordLabelsStr '[] where+    recordLabelsStr _ = []+instance (RecordLabelsStr xs,+          ShowLabel x) => RecordLabelsStr (Tagged x t ': xs) where+    recordLabelsStr _ = showLabel (Label :: Label x) :+                            recordLabelsStr (undefined :: Record xs)++{- |++This alternative option works too, but for whatever reason+splitting up recordLabelsStr and recordLabels into two functions+means that a type annotation is needed on the 3, which is not+necessary with the above recordLabelsStr (ghc-7.6.3)++> recordLabelsStr2 (recordLabels (((Label :: Label "x") .=. 3 .*. emptyRecord )))++-}+class RecordLabelsStr2 (xs :: [k]) where+    recordLabelsStr2 :: proxy xs -> [String]++instance RecordLabelsStr2 '[] where+    recordLabelsStr2 _ = []+instance (RecordLabelsStr2 xs,+          ShowLabel x) => RecordLabelsStr2 (x ': xs) where+    recordLabelsStr2 _ = showLabel (Label :: Label x) :+                            recordLabelsStr2 (Proxy :: Proxy xs)+++-- | use only with @instance Data (HList a)@. This is because the HFoldl+-- context cannot be written for a @c@ that only appears in the method+-- 'gfoldl'.+data C a++-- typeable isntances... either hand written or derived when possible+#if !OLD_TYPEABLE+deriving instance Typeable Record+deriving instance Typeable HList+deriving instance Typeable HListFlat+deriving instance Typeable Variant+deriving instance Typeable TIC+deriving instance Typeable TIP++-- orphans+deriving instance Typeable 'HZero+deriving instance Typeable 'HSucc++#else+instance TypeRepsList (Record xs) => Typeable (HList xs) where+   typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.HList" "HList")+                [ tyConList (typeRepsList (Record x)) ]++instance (TypeRepsList (Record xs)) => Typeable (Record xs) where+  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 (Label :: Label sy)))+        []++instance (ShowLabel sy, Typeable x) => Typeable (Tagged sy x) where+  typeOf _ = mkTyConApp+            (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label sy)))+            [mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "=") [],+                    typeOf (error "Data.HList.Data:Typeable Tagged" :: x)+                    ]+++instance Typeable (HList a) => Typeable (HListFlat a) where+    typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Data" "HListFlat")+            [typeOf (error "Typeable HListFlat" :: HList a)]++-- 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 (HList xs)) => TypeRepsList (Record xs) where+  typeRepsList (Record xs) = typeRepsList xs++instance (TypeRepsList (HList xs), Typeable x) => TypeRepsList (HList (x ': xs)) where+  typeRepsList (~(x `HCons` xs))+        = typeOf x : typeRepsList xs++instance TypeRepsList (HList '[]) where+  typeRepsList _ = []++++-- | wraps up the first argument to 'gfoldl'+data GfoldlK c where+    GfoldlK :: (forall d b . Data d => c (d -> b) -> d -> c b) -> GfoldlK c++instance (Data d, (c (d -> b), d) ~ x, c b ~ y) =>+        ApplyAB (GfoldlK c) x y where+    applyAB (GfoldlK f) (u,v) = f u v+++data GunfoldK c where+    GunfoldK :: (forall b r. Data b => c (b -> r) -> c r) -> GunfoldK c++instance (Data b, x ~ (t, c (b -> r)), y ~ c r) =>+        ApplyAB (GunfoldK c) x y where+    applyAB (GunfoldK f) (_, u) = f u++
+ Data/HList/Dredge.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+-- TryCollectionList needs overlap+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+{- | Description: access nested records/variants given only the last label along a path -}+module Data.HList.Dredge where++import Data.HList.Record+import Data.HList.Variant+import Data.HList.HList+import Data.HList.TIP+import Data.HList.TIC+import Data.HList.FakePrelude+import Data.HList.Labelable+import LensDefs (isSimple)+import Data.HList.TypeEqO () -- if this is missing, dredge fails+++#if (__GLASGOW_HASKELL__ == 800)+-- https://ghc.haskell.org/trac/ghc/ticket/13371+toLabelx x = toLabelSym x+#else+toLabelx x = toLabel x+#endif++{- |++Using HListPP syntax for short hand, @dredge `foo@ expands out to+something like @`path . `to . `foo@, with the restriction that+there is only one possible @`path .  `to@ which leads to the+label @foo@.++For example, if we have the following definitions,++> type BVal a = Record '[Tagged "x" a, Tagged "a" Char]+> type R a = Record  [Tagged "a" Int, Tagged "b" (BVal a)]+> type V a = Variant [Tagged "a" Int, Tagged "b" (BVal a)]+> lx = Label :: Label "x"++Then we have:++> dredge `x :: Lens (R a) (R b) a b+> dredge lx :: Lens (R a) (R b) a b++> dredge `x :: Traversal (V a) (V b) a b -- there were only variants along the path we'd get a Prism+> dredge lx :: Traversal (V a) (V b) a b++[@result-type directed operations are supported@]++There are two ways to access a field with tag @a@ in the R type+defined above, but they result in fields with different types+being looked up:++> `a        :: Lens' (R a) Char+> `b . `a   :: Lens' (R a) Int++so provided that the result type is disambiguated by the context,+the following two types can happen++> dredge `a :: Lens' (R a) Char+> dredge `a :: Lens' (R a) Int+++[@TIP & TIC@]++type indexed collections are allowed along those paths, but+as explained in the 'Labelable' instances, only simple optics+(Lens' / Prism' / Traversal' ) are produced. @dredgeTI'@+works better if the target is a TIP or TIC++-}+dredge label = getSAfromOutputOptic $ \ pr pa ->+      hLens'Path (labelPathEndingWithTD pr (toLabelx label) pa)++++getSAfromOutputOptic :: (p a fb -> p rs rft) ~ stab+                => (Proxy (rs :: *) -> Proxy (a :: *) -> stab) -> stab+getSAfromOutputOptic f = f Proxy Proxy+++-- | 'dredge' except a simple (s ~ t, a ~ b) optic is produced+dredge' label = isSimple (dredge label)+++-- | dredgeND (named directed only) is the same as 'dredge', except the+-- result type (@a@) is not used when the label would otherwise+-- be ambiguous. dredgeND might give better type errors, but otherwise+-- there should be no reason to pick it over dredge+dredgeND label = getSAfromOutputOptic $ \ pr _a ->+      hLens'Path (labelPathEndingWith pr (toLabelx label))+++-- | 'dredgeND' except a simple (s ~ t, a ~ b) optic is produced+dredgeND' label = isSimple (dredgeND label)+++{- | The same as dredgeND', except intended for TIP/TICs because+the assumption is made that @l ~ v@ for the @Tagged l v@ elements.+In other words, ticPrism' and 'tipyLens'' could usually+be replaced by++> dredgeTI' :: _ => Label a -> Lens'  (TIP s) a+> dredgeTI' :: _ => Label a -> Prism' (TIC s) a++where we might have @s ~ '[Tagged a a, Tagged b b]@++-}+dredgeTI' label = isSimple lens where+        lens = getSAfromOutputOptic $ \ pr pa ->+            hLens'Path (labelPathEndingWith pr (pa `proxyTypeOf` label))++        proxyTypeOf :: p a -> q a -> Label a+        proxyTypeOf _ _ = Label+++-- | @HSingleton msg xs x@ is like @'[x] ~ xs@ if that constraint can hold,+-- otherwise it is @Fail msg@. See comments on 'Fail' about how its kind+-- varies with ghc version.+class HSingleton (msgAmb :: m) (msgEmpty :: m2) (ns :: [k]) (p :: k) | ns -> p+instance HSingleton m1 m2 '[n] n+instance (Fail m2, Any ~ a) => HSingleton m1 m2 '[] a+instance (Fail m1, Any ~ a) => HSingleton m1 m2 (n1 ': n2 ': n3) a+++-- | @HGuardNonNull msg xs@ is like @when (null xs) (fail msg)@+class HGuardNonNull emptymsg (xs :: [k])++instance Fail msg => HGuardNonNull msg '[]+instance             HGuardNonNull msg (x ': xs)+++-- | @ConsTrue b x xs r@ is like @r = if b then x:xs else xs@+class ConsTrue (b :: Bool) (x :: k) (xs :: [k]) (r :: [k]) | b x xs -> r, r b -> xs, x xs r -> b+instance ConsTrue True x xs (x ': xs)+instance ConsTrue False x xs xs++-- | @FilterLastEq x xs ys ys'@ determines ys' such that it+-- contains all of the @ys !! i@ such that @last (xs !! i) == x@.+-- In other words it is like+--+-- > ys' = [ y |  (xsElt, y) <- zip xs ys, last xsElt == x ]+class FilterLastEq (x :: k) (xs :: [[k]]) (ys :: [m]) (ys' :: [m]) | x xs ys -> ys'+instance (HReverse path (y' ': rest), HEq y y' b, ConsTrue b z r1 r,+          FilterLastEq y xs zs r1) => FilterLastEq y (path ': xs) (z ': zs) r++instance FilterLastEq y '[] '[] '[]++-- | The same as 'FilterLastEq' except @id@ is used instead of @last@+class FilterVEq (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'++instance FilterVEq v '[] '[] '[]++instance+   (HEq v v' b,+    ConsTrue b n ns1 ns2,+    FilterVEq v vs ns ns1)+    => FilterVEq v (v' ': vs) (n ': ns) ns2++-- | like @FilterVEq@, except if there is+class FilterVEq1 (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'+instance (v ~ v') => FilterVEq1 v '[ v' ] ns ns+instance FilterVEq1 v '[] '[] '[]+instance FilterVEq v (a ': b ': c)  ns ns' => FilterVEq1 v (a ': b ': c) ns ns'++-- | @LabelPathEndingWith r l path@+--+-- determines a unique path suitable for 'hLookupByLabelPath'+-- (calling 'Fail' otherwise) through the+-- nested records/variants in r ending with l+class LabelPathEndingWith (r :: *) (l :: k) (path :: [*]) | r l -> path where+    labelPathEndingWith :: proxy r -> Label l -> Label path+    labelPathEndingWith _ _ = Label++instance+   (FieldTree r ns,+    FilterLastEq (Label l) ns ns ns',+    HSingleton (NonUnique' r l) (NamesDontMatch r ns l) ns' path)+    => LabelPathEndingWith r l path+++labelPathEndingWithTD :: forall r l v path+                                vs vs1 ns ns1 ns2.+   (SameLength ns vs,+    SameLength ns1 vs1,+    FieldTree r ns,+    FieldTreeVal r vs,+    FilterLastEq (Label l) ns ns ns1,+    FilterLastEq (Label l) ns vs vs1,+    FilterVEq1 v vs1 ns1 ns2,++    HGuardNonNull (NamesDontMatch r ns l) ns1,++    -- '[path] ~ ns2, plus error reporting if ns2 has >1 or 0 elements+    HSingleton (NonUnique r v l) (TypesDontMatch r ns1 vs1 v) ns2 path)+    => Proxy r -> Label l -> Proxy v -> Label path+labelPathEndingWithTD _ _ _ = Label+++type NamesDontMatch r ns l = ErrShowType r+  :$$: ErrText "has paths"  :<>: ErrShowType ns+  :$$: ErrText "but none which end in the desired label" :<>: ErrShowType l++type NonUnique' r l = ErrText "Path ending in label " :<>: ErrShowType l+  :$$: ErrText "is not unique in " :<>: ErrShowType r++type NonUnique r v l = NonUnique' r l+  :$$: ErrText "also considering the v type " :<>: ErrShowType v++{- | XXX++> let x = 'x'; y = [pun| x |]; z = [pun| y |]+> z & dredge (Label :: Label "x") %~ (succ :: Int -> Int)++Should reference this type error, but for whatever reason it doesn't++-}+type TypesDontMatch r ns1 vs1 v = ErrShowType r+  :$$: ErrText "has potential paths with the right labels" :<>: ErrShowType ns1+  :$$: ErrText "which point at types" :<>: ErrShowType vs1 :<>: ErrText "respectively"+  :$$: ErrText "but none of these match the desired type" :<>: ErrShowType v++-- | see 'hLookupByLabelPath'+hLookupByLabelDredge l r = labelPathEndingWith (toProxy r) l `hLookupByLabelPath` r+  where toProxy :: r x -> Proxy x+        toProxy _ = Proxy++{- | lookup along a path++>>> let v = mkVariant1 Label (mkVariant1 Label 'r') :: Variant '[Tagged "x" (Variant '[Tagged "y" Char])]+>>> let r = hBuild (hBuild 'r') :: Record '[Tagged "x" (Record '[Tagged "y" Char])]+>>> let p = Label :: Label [Label "x", Label "y"]+>>> let lx = Label :: Label "y"++>>> hLookupByLabelPath p v+Just 'r'++>>> hLookupByLabelPath p r+'r'++>>> hLookupByLabelDredge lx v+Just 'r'++>>> hLookupByLabelDredge lx r+'r'++-}+hLookupByLabelPath :: HasFieldPath False ls r v => Label ls -> r -> v+hLookupByLabelPath labels r = hLookupByLabelPath1 hFalse labels r++{- |++> hLens'Path labc == hLens' la . hLens' lb . hLens' lc+>  where+>       la :: Label "a"+>       lb :: Label "b"+>       lc :: Label "c"+>       labc :: Label '["a", "b", "c"]++-}+class LabelablePath (xs :: [*]) apb spt | spt xs -> apb where+    hLens'Path :: Label xs -> apb -> spt++instance (Labelable x r s t a b,+          j ~ (a `p` f b),+          k ~ (r s `p` f (r t)),+          ty ~ LabelableTy r,+          LabeledOpticP ty p,+          LabeledOpticF ty f,+          LabeledOpticTo ty x (->),+          LabelablePath xs i j) => LabelablePath (Label x ': xs) i k where+    hLens'Path _ = (hLens' (Label :: Label x) :: j -> k) . hLens'Path (Label :: Label xs)++instance (x ~ x') => LabelablePath '[] x x' where+    hLens'Path _ = id++class HasFieldPath (needJust :: Bool) (ls :: [*]) r v | needJust ls r -> v where+    -- | use 'hLookupByLabelPath' instead+    hLookupByLabelPath1 :: Proxy needJust -> Label ls -> r -> v++instance HasFieldPath False '[] v v where+    hLookupByLabelPath1 _ _ = id++instance HasFieldPath True '[] v (Maybe v) where+    hLookupByLabelPath1 _ _ = Just++instance (HasField l (Record r) u, HasFieldPath needJust ls u v)+    => HasFieldPath needJust (Label l ': ls) (Record r) v where+     hLookupByLabelPath1 needJust _ = hLookupByLabelPath1 needJust (Label :: Label ls)+                                . hLookupByLabel (Label :: Label l)++instance (HasField l (Variant r) (Maybe u), HasFieldPath True ls u (Maybe v))+    => HasFieldPath needJust (Label l ': ls) (Variant r) (Maybe v) where+     hLookupByLabelPath1 _ _ v = hLookupByLabelPath1 hTrue (Label :: Label ls) =<< hLookupByLabel (Label :: Label l) v++++++{- | @(FieldTree r ns, FieldTreeVal r vs)@++defines ns and vs such that looking up path (ns !! i) in r gives the type+(vs !! i). This is almost @HasFieldPath False (ns !! i) (vs !! i)@, except+there is no additional Maybe when a Variant is encountered along the path+(and we don't have a type level @!!@)+-}+class FieldTreeVal (r :: *) (v :: [*]) | r -> v++class MapFieldTreeVal (r :: *) (ns :: Maybe [*]) (vs :: [*]) | r ns -> vs++instance (TryCollectionList r ns, MapFieldTreeVal r ns v) => FieldTreeVal r v++instance MapFieldTreeVal r Nothing '[]++instance ( MapFieldTreeVal r (Just xs) out2,+           FieldTreeVal v out1,+           (v ': HAppendListR out1 out2) ~ out)+  => MapFieldTreeVal r (Just (Tagged n v ': xs))  out++instance MapFieldTreeVal r (Just '[]) '[]++{- | list all paths through nested records or variants.+An example instance would be++> FieldTree r v++where++> v ~ [[ Label "x",  Label Dat ], '[Label "y"], '[Label "x"] ]+> r ~ Record [ Tagged "x" x, Tagged "y" String ]+>+> x ~ Variant '[ Tagged Dat Char ]++-}+class FieldTree (r :: *) (v :: [[*]]) | r -> v++-- | the only instance+instance (TryCollectionList r ns, MapFieldTree ns vs) => FieldTree r vs+++#if (__GLASGOW_HASKELL__ >= 800)+-- possibly https://ghc.haskell.org/trac/ghc/ticket/13284+-- dredge' x = (isSimple . dredge) x+--     • Overlapping instances for TryCollectionList r0 ns0+--         arising from a use of ‘dredge’+--       Matching instances:+--         instance [overlappable] nothing ~ 'Nothing =>+--                                 TryCollectionList x nothing+--           -- Defined at /home/aavogt/wip/HList/HList/Data/HList/Dredge.hs:340:31+--         ...plus four instances involving out-of-scope types+--         (use -fprint-potential-instances to see them all)+--       (The choice depends on the instantiation of ‘r0, ns0’+--        To pick the first instance above, use IncoherentInstances+--        when compiling the other instance declarations)+--+-- attempt to resolve that with a closed type family++type family TryCollectionListTF (r :: *) :: Maybe [*] where+  TryCollectionListTF (Record r) = Just r+  TryCollectionListTF (Variant r) = Just r+  TryCollectionListTF (TIC r) = Just r+  TryCollectionListTF (TIP r) = Just r+  TryCollectionListTF nothing = Nothing++type TryCollectionList r v = (v ~ TryCollectionListTF r)++#else+-- | try to extract the list applied to the Record or Variant+class TryCollectionList (r :: *) (v :: Maybe [*]) | r -> v++instance {-# OVERLAPPABLE #-} (nothing ~ Nothing) => TryCollectionList x nothing+instance {-# OVERLAPPING  #-} TryCollectionList (Record  r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (Variant r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (TIC r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (TIP r) (Just r)+#endif++class MapFieldTree (ns :: Maybe [*]) (vs :: [[*]]) | ns -> vs++instance MapFieldTree Nothing '[]++-- | recursive case+instance (+    MapFieldTree (Just xs) vs3,+    FieldTree v vs1,+    MapCons (Label n) ('[] ': vs1) vs2,+    HAppendListR vs2 vs3 ~ vs)+    => MapFieldTree (Just (Tagged n v ': xs)) vs++instance MapFieldTree (Just '[]) '[]++-- | MapCons x xs xxs is like  xxs = map (x : ) xs+class MapCons (x :: k) (xs :: [[k]]) (xxs :: [[k]]) | x xs -> xxs+instance MapCons x '[] '[]+instance MapCons x b r => MapCons x (a ': b) ( (x ':  a) ': r)++
Data/HList/FakePrelude.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE CPP #-}  {- |    The HList library@@ -8,255 +8,824 @@    Some very basic technology for faking dependent types in Haskell. -} -module Data.HList.FakePrelude where+module Data.HList.FakePrelude+    (module Data.HList.FakePrelude,+     -- * re-exports+     module Data.Proxy,+     module Data.Tagged,+     Monoid(..),+     Any) where +import Data.Proxy+import Data.Tagged+import GHC.Exts (Constraint,Any)+import GHC.TypeLits+#if __GLASGOW_HASKELL__ >= 800+import qualified GHC.TypeLits as Data.HList.FakePrelude (ErrorMessage((:$$:), (:<>:))) -- XXX check this works?+#endif+#if __GLASGOW_HASKELL__ <= 906+import Control.Applicative+#endif+#if NEW_TYPE_EQ+import Data.Type.Equality (type (==))+#endif -{-----------------------------------------------------------------------------}+#if !OLD_TYPEABLE+import Data.Typeable+#endif --- * Booleans+#if __GLASGOW_HASKELL__ < 709+import Data.Monoid (Monoid(..))+#endif -data HTrue; hTrue :: HTrue; hTrue = undefined-data HFalse; hFalse :: HFalse; hFalse = undefined-class HBool x; instance HBool HTrue; instance HBool HFalse-instance Show HTrue where show _ = "HTrue"-instance Show HFalse where show _ = "HFalse" +-- --------------------------------------------------------------------------+-- * A heterogeneous apply operator --- **  Conjunction+-- | simpler/weaker version where type information only propagates forward+-- with this one. 'applyAB' defined below, is more complicated / verbose to define,+-- but it offers better type inference. Most uses have been converted to+-- '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 -class (HBool t, HBool t', HBool t'') => HAnd t t' t'' | t t' -> t''- where-  hAnd :: t -> t' -> t''+{- $note -instance HAnd HFalse HFalse HFalse- where-  hAnd _ _ = hFalse+ Polymorphic functions are not first-class in haskell. An example of this+ is: -instance HAnd HTrue HFalse HFalse- where-  hAnd _ _ = hFalse+ > f op = (op (1 :: Double), op (1 :: Int)) -instance HAnd HFalse HTrue HFalse- where-  hAnd _ _ = hFalse+ [@RankNTypes@] -instance HAnd HTrue HTrue HTrue+ 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++ Normally you would have been able to pass around the definition actual_fn.++ [@Type inference / Local functional dependencies@]++ Note that @class ApplyAB@ has three parameters and no functional dependencies.+ Instances should be written in the style:++ > instance (int ~ Int, double ~ Double) => ApplyAB Fn int double+ >  where applyAB _ = fromIntegral++ rather than the more natural++ > instance ApplyAB Fn Int Double++ 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@. 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+++{- $fun++ 'Fun' can be used instead of writing a new instance of+ 'ApplyAB'. Refer to the definition/source for the the most+ concise explanation. A more wordy explanation is given below:++ A type signature needs to be provided on 'Fun' to make it work.+ Depending on the kind of the parameters to 'Fun', a number of+ different results happen.+++ [@ex1@]++ A list of kind @[* -> Constraint]@ produces those+ constraints on the argument type:++ >>> :set -XDataKinds+ >>> let plus1f x = if x < 5 then x+1 else 5+ >>> let plus1 = Fun plus1f :: Fun '[Num, Ord] '()+ >>> :t applyAB plus1+ 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.+++ A single constraint can also be supplied:++ >>> let succ1 = Fun succ :: Fun Enum '()+ >>> :t applyAB succ1+ applyAB succ1 :: Enum b => b -> b+++ >>> let just = Fun Just :: Fun '[] Maybe+ >>> :t applyAB just+ applyAB just :: a -> Maybe a+++-}+data Fun (cxt :: k1) (getb :: k2)+    = Fun (forall a. FunCxt cxt a => a -> FunApp getb a)++{- | see 'Fun'. The only difference here is that the argument+type is calculated from the result type.++ >>> let rd = Fun' read :: Fun' Read String+ >>> :t applyAB rd+ applyAB rd :: Read b => [Char] -> b++ >>> let fromJust' = Fun' (\(Just a) -> a) :: Fun' '[] Maybe+ >>> :t applyAB fromJust'+ applyAB fromJust' :: Maybe b -> b++Note this use of Fun' means we don't have to get the b out of @Maybe b@,+++-}+data Fun' (cxt :: k1) (geta :: k2)+    = Fun' (forall b. FunCxt cxt b => FunApp geta b -> b)+++type family FunApp (fns :: k) a++type instance FunApp (fn :: *) a = fn+type instance FunApp (fn :: * -> *) a = fn a+type instance FunApp (fn :: ()) a = a++type family FunCxt (cxts :: k) a :: Constraint+type instance FunCxt (x ': xs) a = (x a, FunCxt xs a)+type instance FunCxt (cxt :: * -> Constraint) a = cxt a+type instance FunCxt '[] a = ()+-- | should there be so many ways to write no constraint?+type instance FunCxt (cxt :: ()) a = ()+type instance FunCxt (cxt :: *) a = (cxt ~ a)++instance (FunCxt cxt a, FunApp getb a ~ b)  => ApplyAB (Fun cxt getb) a b where+    applyAB (Fun f) x = f x++instance (FunCxt cxt b, FunApp geta b ~ a)  => ApplyAB (Fun' cxt geta) a b where+    applyAB (Fun' f) x = f x+++++-- ** Simple useful instances of Apply+-- | note this function will only be available at a single type+-- (that is, @hMap succ@ will only work on 'HList' that contain+-- only one type)+instance (x' ~ x, y' ~ y) => ApplyAB (x' -> y') x y where+  applyAB f x = f x++++{- | print. An alternative implementation could be:++>>> let hPrint = Fun print :: Fun Show (IO ())++This produces:++>>> :t applyAB hPrint+applyAB hPrint :: Show a => a -> IO ()++-}+data HPrint = HPrint++instance (io ~ IO (), Show x) => ApplyAB HPrint x io where+  applyAB _ x = print x++++{- | read++>>> applyAB HRead "5.0" :: Double+5.0++-}+data HRead = HRead+instance (String ~ string, Read a) => ApplyAB HRead string a where+    applyAB _ x = read x++-- | show+data HShow = HShow+instance (String ~ string, Show a) => ApplyAB HShow a string where+    applyAB _ x = show x++++++{- | Compose two instances of 'ApplyAB'++>>> applyAB (HComp HRead HShow) (5::Double) :: Double+5.0++-}+data HComp g f = HComp g f -- ^ @g . f@++instance (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where+    applyAB ~(HComp g f) x = applyAB g (applyAB f x :: b)+++{- | @app Comp (f,g) = g . f@. Works like:++>>> applyAB Comp (succ, pred) 'a'+'a'++>>> applyAB Comp (toEnum :: Int -> Char, fromEnum) 10+10++Note that defaulting will sometimes give you the wrong thing++> used to work (with associated types calculating result/argument types)+> >>> applyAB Comp (fromEnum, toEnum) 'a'+> *** Exception: Prelude.Enum.().toEnum: bad argument++-}+data Comp = Comp++instance (y ~ y', fg ~ (x -> y, y' -> z), r ~ (x -> z)) => ApplyAB Comp fg  r  where-  hAnd _ _ = hTrue+  applyAB _ (f,g) = g . f +-- | (\(a,b) -> f a >> b)+newtype HSeq x = HSeq x+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 ()+          asVoid t = t +++-- | @HJust ()@ is a placeholder for a function that applies the 'HJust' constructor+instance hJustA ~ HJust a => ApplyAB (HJust t) a hJustA where+    applyAB _ a = HJust a+++-- | 'flip'+data HFlip = HFlip++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.Proxy"++-- | A special 'Proxy' for record labels, polykinded+data Label l = Label++labelToProxy :: Label l -> Proxy l+labelToProxy _ = Proxy++class ShowLabel l where+  showLabel :: Label l -> String+++-- --------------------------------------------------------------------------++-- * Booleans++{- $boolNote++GHC already lifts booleans, defined as++> data Bool = True | False++to types: Bool becomes kind and True and False (also denoted by+'True and 'False) become nullary type constructors.++The above line is equivalent to++> data HTrue+> data HFalse++> class HBool x+> instance HBool HTrue+> instance HBool HFalse++-}++-- ** Value-level proxies+hTrue  :: Proxy True ; hTrue  = Proxy+hFalse :: Proxy False; hFalse = Proxy+++-- **  Conjunction++type family HAnd (t1 :: Bool) (t2 :: Bool) :: Bool+type instance HAnd False t  = False+type instance HAnd True  t  = t++-- | `demote' to values+hAnd :: Proxy t1 -> Proxy t2 -> Proxy (HAnd t1 t2)+hAnd _ _ = Proxy++ -- ** Disjunction -class (HBool t, HBool t', HBool t'') => HOr t t' t'' | t t' -> t''- where-  hOr :: t -> t' -> t''+type family HOr (t1 :: Bool) (t2 :: Bool) :: Bool+type instance HOr False t    = t+type instance HOr True t     = True -instance HOr HFalse HFalse HFalse- where-  hOr _ _ = hFalse+-- | `demote' to values+hOr :: Proxy t1 -> Proxy t2 -> Proxy (HOr t1 t2)+hOr _ _ = Proxy -instance HOr HTrue HFalse HTrue- where-  hOr _ _ = hTrue+{- $boolHistoricalNote -instance HOr HFalse HTrue HTrue- where-  hOr _ _ = hTrue+Compare with the original code based on functional dependencies: -instance HOr HTrue HTrue HTrue- where-  hOr _ _ = hTrue+> class (HBool t, HBool t', HBool t'') => HOr t t' t'' | t t' -> t''+>  where+>   hOr :: t -> t' -> t'' +> instance HOr HFalse HFalse HFalse+>  where+>   hOr _ _ = hFalse --- ** Conditional+> instance HOr HTrue HFalse HTrue+>  where+>   hOr _ _ = hTrue -class HBool t => HCond t x y z | t x y -> z+> instance HOr HFalse HTrue HTrue+>  where+>   hOr _ _ = hTrue++> instance HOr HTrue HTrue HTrue+>  where+>   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 :: t -> x -> y -> z+  hCond :: Proxy t -> x -> y -> z -instance HCond HFalse x y y+instance HCond False x y y  where   hCond _ _ y = y -instance HCond HTrue x y x+instance HCond True x y x  where   hCond _ x _ = x  +-- ** Boolean equivalence++type family HBoolEQ (t1 :: Bool) (t2 :: Bool) :: Bool+type instance HBoolEQ False False    = True+type instance HBoolEQ False True     = False+type instance HBoolEQ True  False    = False+type instance HBoolEQ True  True     = True+ -- We could define all kinds of further Boolean operations. -- We omit everything what's not needed for the code in the paper. --{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------  -- * Naturals -data HZero-data HSucc n+-- | The data type to be lifted to the type level+data HNat = HZero | HSucc HNat -hZero :: HZero; hZero = undefined-hSucc :: HNat n => n -> HSucc n; hSucc _ = undefined-hPred :: HNat n => HSucc n -> n; hPred _ = undefined -class HNat n-instance HNat HZero-instance HNat n => HNat (HSucc n)+hZero :: Proxy HZero; hZero = Proxy+hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = Proxy+hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = Proxy -instance Show HZero where show _ = "HZero"-instance Show (HSucc HZero)- where show _ = "HSucc HZero"-instance (HNat n, Show (HSucc n)) => Show (HSucc (HSucc n))- where show n = "HSucc (" ++ show (hPred n) ++ ")"+class HNat2Integral (n::HNat) where+    hNat2Integral :: Integral i => Proxy n -> i -class HNat n => HNat2Integral n- where-  hNat2Integral :: Integral i => n -> i+type family HNat2Nat (n :: HNat) :: Nat+type instance HNat2Nat HZero = 0+type instance HNat2Nat (HSucc n) = 1 + HNat2Nat n -instance HNat2Integral HZero- where-  hNat2Integral _ = 0+#if MIN_VERSION_base(4,7,0)+{- Instead convert HNat to GHC.TypeLits.'Nat' with 'HNat2Nat' and use functions+from that module to produce the 'Integer' -}+instance KnownNat (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (natVal (Proxy :: Proxy (HNat2Nat n)))+#else+{- doesn't work: gives "No instance for (SingI Nat (1 + (1 + 0)))"+instance SingI (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (fromSing (sing :: Sing (HNat2Nat n)))+-} -instance HNat2Integral n => HNat2Integral (HSucc n)- where-  hNat2Integral n = hNat2Integral (hPred n) + 1+-- | a slow (at runtime) implementation for ghc 7.6:+instance HNat2Integral HZero where+    hNat2Integral _ = 0 +instance HNat2Integral n => HNat2Integral (HSucc n) where+    hNat2Integral n = hNat2Integral (hPred n) + 1+#endif -{-----------------------------------------------------------------------------} +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+type instance HNatEq HZero HZero          = True+type instance HNatEq HZero (HSucc n)      = False+type instance HNatEq (HSucc n) HZero      = False+type instance HNatEq (HSucc n) (HSucc n') = HNatEq  n n'+++-- | Less than++type family HLt (x :: HNat) (y :: HNat) :: Bool++type instance HLt HZero HZero          = False+type instance HLt HZero (HSucc n)      = True+type instance HLt (HSucc n) HZero      = False+type instance HLt (HSucc n) (HSucc n') = HLt  n n'++hLt :: Proxy x -> Proxy y -> Proxy (HLt x y)+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 -data HNothing  = HNothing  deriving Show-data HJust x   = HJust x   deriving Show+data    HNothing  = HNothing  deriving Show+newtype HJust x   = HJust x   deriving Show  -{-----------------------------------------------------------------------------}+-- -------------------------------------------------------------------------- --- * Equality for types+-- * Polykinded Equality for types+-- | We have to use Functional dependencies for now,+-- for the sake of the generic equality.+class HEq (x :: k) (y :: k) (b :: Bool) | x y -> b -class HBool b => HEq x y b | x y -> b+-- | 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 --- Equality instances for naturals+#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 -instance HEq HZero HZero HTrue-instance HNat n => HEq HZero (HSucc n) HFalse-instance HNat n => HEq (HSucc n) HZero HFalse-instance (HNat n, HNat n', HEq  n n' b )-      =>  HEq (HSucc n) (HSucc n') b+hEq :: HEq x y b => x -> y -> Proxy b+hEq _ _ = Proxy -hEq :: HEq x y b => x -> y -> b-hEq =  undefined +-- | 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 -- | -- --  * Establish type equality statically -- --  * 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 -{-----------------------------------------------------------------------------} --- | Less than+-- * Cast -class HBool b => HLt x y b | x y -> b+-- | Named after 'Data.Typeable.cast', which behaves the same at runtime.+-- One difference is that there is a HCast instance for every type, while+-- 'Typeable' instances can be missing sometimes. +class HCast x y where+    hCast :: x -> Maybe y --- Equality instances for naturals+instance (HEq x y b, HCast1 b x y) => HCast x y where+    hCast = hCast1 (Proxy :: Proxy b) -instance HLt HZero HZero HFalse-instance HNat n => HLt HZero (HSucc n) HTrue-instance HNat n => HLt (HSucc n) HZero HFalse-instance (HNat n, HNat n', HLt  n n' b)-      =>  HLt (HSucc n) (HSucc n') b+-- | helper for 'HCast'+class HCast1 (b :: Bool) x y where+    hCast1 :: Proxy b -> x -> Maybe y -hLt   :: HLt x y b => x -> y -> b-hLt _ =  undefined+instance (x ~ y) => HCast1 True x y where+    hCast1 _ x = Just x +instance HCast1 False x y where+    hCast1 _ _ = Nothing -{-----------------------------------------------------------------------------} --- | A predicate for type equality------ There are different implementations.------ See imports in Main*.hs -class HBool b => TypeEq x y b | x y -> b +-- -------------------------------------------------------------------------- --- Rely on lazy show for type-level Booleans-typeEq :: TypeEq t t' b => t -> t' -> b-typeEq = undefined+-- * Error messages +{- | A class without instances for explicit failure. --- A more disciplined version: based on proxies-proxyEq :: TypeEq t t' b => Proxy t -> Proxy t' -> b-proxyEq _ _ = undefined+Note that with ghc>=8.0, `x :: TypeError` which is formatted properly.+Otherwise `x` is made of nested (left-associated) promoted tuples.+For example: +> (x ~ '( '( '("the", Int), "is wrong") ) ) :: ((,) Symbol *, Symbol) -{-----------------------------------------------------------------------------}+Therefore code that works across ghc-7.6 through ghc-8.0 needs to+use ErrText, ErrShowType, :<>:, :$$: to construct the type x.  -}+class Fail (x :: k) --- * Type-safe cast+#if __GLASGOW_HASKELL__ >= 800+-- | use the alias ErrText to prevent conflicts with Data.Text+--+-- GHC.TypeLits.:<>: and GHC.TypeLits.:$$: are re-exported+type ErrText x = GHC.TypeLits.Text x+type ErrShowType x = GHC.TypeLits.ShowType x -class TypeCast x y | x -> y, y -> x- where-  typeCast :: x -> y+-- type Fail = TypeError -- another option+instance TypeError x => Fail x+#else +type ErrText x = x+type ErrShowType x = x+type x :<>: y = '(x,y)+type x :$$: y = '(x,y)+infixl 6 :<>:+infixl 5 :$$:+#endif -{-----------------------------------------------------------------------------}+-- ** Error messages used elsewhere+type FieldNotFound key collection = ErrText "key" :<>: ErrShowType key+      :$$: ErrText "could not be found in" :<>: ErrShowType collection --- * A phantom type for type proxies+type ExcessFieldFound key collection = ErrText "found field" :<>: ErrShowType key+      :$$: ErrText "when it should be absent from" :<>: ErrShowType collection -data Proxy e-instance Show (Proxy e) where show _ = "Proxy"+type HNatIndexTooLarge (nat :: HNat) (r :: [k] -> *) (xs :: [k]) =+      ErrText "0-based index" :<>: ErrShowType (HNat2Nat nat) :<>:+      ErrText "is too large for collection"+            :$$: ErrShowType (r xs)+    -- :$$: ErrText "(length: " :<>: ErrShowType (HNat2Nat (HLength collection)) :<>: ErrText " )"+    -- Data.HList.HList.HLength isn't available here -proxy :: Proxy e-proxy =  undefined+type ExtraField x = ErrText "extra field" :<>: ErrShowType x -toProxy :: e -> Proxy e-toProxy _ = undefined -unProxy :: Proxy e -> e-unProxy =  undefined+#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 --- * Type equality and disequality+{- | symmetrical version of 'SameLength''. Written as a class instead of -class TypeEqTrue x y-class TypeEqFalse x y+ > type SameLength a b = (SameLength' a b, SameLength' b a) -typeEqTrue :: TypeEqTrue x y => x -> y -> ()-typeEqTrue _ _ = ()+since ghc expands type synonyms, but not classes (and it seems to have the same+result) -typeEqFalse :: TypeEqFalse x y => x -> y -> ()-typeEqFalse _ _ = ()+-}+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 --- * Subtyping+-- | 'asTypeOf'+asLengthOf :: SameLength x y => r x -> s y -> r x+asLengthOf = const -class SubType l l' -subType :: SubType l l' => l -> l' -> ()-subType _ _ = ()+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 --- * Error messages+class SameLabels (x :: k) (y :: m) --- | A class without instances for explicit failure-class Fail x+{- | @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/GhcExperiments.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE KindSignatures,MultiParamTypeClasses,FunctionalDependencies,FlexibleInstances, FlexibleContexts, UndecidableInstances, OverlappingInstances #-}--{--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   This module gathers experiments that do not work with Hugs.--}--module Data.HList.GhcExperiments where--import Data.HList.FakePrelude-import Data.HList.HListPrelude--class HDeleteMany e l l' | e l -> l'- where-  hDeleteMany :: Proxy e -> l -> l'--instance HDeleteMany e HNil HNil- where-  hDeleteMany _ HNil = HNil--instance (HList l, HDeleteMany e l l')-      => HDeleteMany e (HCons e l) l'- where-  hDeleteMany p (HCons _ l) = hDeleteMany p l--{----- Hopelessly overlapping--instance (HList l, HDeleteMany e l l')-      => HDeleteMany e (HCons e' l) (HCons e' l')- where-  hDeleteMany p (HCons e' l)-   =-     HCons e' (hDeleteMany p l)---}--instance ( HList l-         , HDeleteMany e l l'-         , TypeCast (HCons e' l') l''-         )-      =>   HDeleteMany e (HCons e' l) l''- where-  hDeleteMany p (HCons e' l)-   =-     typeCast (HCons e' (hDeleteMany p l))------------------------------------------------------------------------------------ Test for type constructors---- signature: * -> *-class IsTC1 x (f :: * -> *) b | x f -> b-instance TypeCast HTrue b => IsTC1 (f a) f b-instance TypeCast HFalse b => IsTC1 f x b---- signature: * -> * -> *-class IsTC2 x (f :: * -> * -> *) b | x f -> b-instance TypeCast HTrue b => IsTC2 (f a b) f b-instance TypeCast HFalse b => IsTC2 f x b---- Sample-funType :: IsTC2 t (->) b => t -> b-funType = undefined
− Data/HList/GhcRecord.hs 
@@ -1,300 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}--{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Extensible records -- operations that (may) require GHC--   See "Data.HList.Record" for the base module.--}--module Data.HList.GhcRecord where--import Data.HList.FakePrelude-import Data.HList.HListPrelude-import Data.HList.HArray-import Data.HList.Record-import Data.Typeable---{-----------------------------------------------------------------------------}---- | A variation on update.------ Replace a proxy by a value of the proxied type.--- The signature is inferred-hUnproxyLabel :: (HUpdateAtHNat n (LVPair l a) t l', HFind l ls n,-                               RecordLabels t ls,-                               HasField l t (Proxy a)) =>-                                             l -> a -> Record t -> Record l'-hUnproxyLabel l v r = hUpdateAtLabel l v r- where-  tpe :: a -> Proxy a -> ()-  tpe _ _ = ()-  _ = tpe v (hLookupByLabel l r)---{-----------------------------------------------------------------------------}---- | Test for values; refuse proxies--hasNoProxies :: HasNoProxies r-             => Record r -> ()-hasNoProxies = const ()---data ProxyFound x-class HasNoProxies l-instance HasNoProxies HNil-instance Fail (ProxyFound x) => HasNoProxies (HCons (Proxy x) l)-instance Fail (ProxyFound x) => HasNoProxies (HCons (LVPair lab (Proxy x)) l)-instance HasNoProxies l => HasNoProxies (HCons e l)---{-----------------------------------------------------------------------------}---- | Narrow a record to a different record type------ First is the `monadic' version, which returns the `failure indictator'--- (HNothing) if the narrowing fails because the source does not have--- all the fields for the target.-class  NarrowM a b res | a b -> res where-    narrowM :: Record a -> Record b -> res--instance NarrowM a HNil (HJust (Record HNil)) where-    narrowM _ _ = HJust emptyRecord--instance (H2ProjectByLabels (HCons l HNil) a rin rout,-          NarrowM' rin rout b res)-    => NarrowM a (HCons (LVPair l v) b) res where-    narrowM (Record a) _ = narrowM' rin rout (undefined::b)-     where-        (rin,rout) = h2projectByLabels (undefined::(HCons l HNil)) a--class  NarrowM' rin rout b res | rin rout b -> res where-    narrowM' :: rin -> rout -> b -> res--instance NarrowM' HNil rout b HNothing where-    narrowM' _ _ _ = HNothing--instance (NarrowM rout b res',-          NarrowM'' f res' res)-    => NarrowM' (HCons f HNil) rout b res where-    narrowM' (HCons f HNil) rout b =-        narrowM'' f (narrowM (Record rout) (Record b))--class  NarrowM'' f r r' | f r -> r' where-    narrowM'' :: f -> r -> r'--instance NarrowM'' f HNothing HNothing where-    narrowM'' _ _ = HNothing--instance NarrowM'' f (HJust (Record r)) (HJust (Record (HCons f r))) where-    narrowM'' f (HJust (Record r)) = HJust (Record (HCons f r))---class  Narrow a b- where narrow :: Record a -> Record b--instance Narrow a HNil- where   narrow _ = emptyRecord--instance ( Narrow rout r'-         , H2ProjectByLabels (HCons l HNil) r (HCons (LVPair l v) HNil) rout-         ) => Narrow r (HCons (LVPair l v) r')-  where-    narrow (Record r) = Record (HCons f r')-      where-        (HCons f HNil,rout) = h2projectByLabels (undefined::(HCons l HNil)) r-        (Record r')    = narrow (Record rout)---{-----------------------------------------------------------------------------}---- | Narrow two records to their least-upper bound--class LubNarrow a b c | a b -> c- where-  lubNarrow :: a -> b -> (c,c)--instance ( RecordLabels a la-         , RecordLabels b lb-         , HTIntersect la lb lc-         , H2ProjectByLabels lc a c aout-         , H2ProjectByLabels lc b c bout-         , HRLabelSet c-         )-      => LubNarrow (Record a) (Record b) (Record c)- where-  lubNarrow ra@(Record _) rb@(Record _) =-     ( hProjectByLabels (undefined::lc) ra-     , hProjectByLabels (undefined::lc) rb-     )---{-----------------------------------------------------------------------------}---- | List constructors that also LUB together--data NilLub-nilLub :: NilLub-nilLub = undefined--class ConsLub h t l | h t -> l- where-  consLub :: h -> t -> l--instance ConsLub e  NilLub [e]- where-  consLub h _ = [h]--instance LubNarrow e0 e1 e2 => ConsLub e0 [e1] [e2]- where-  consLub h t = fst (head z) : map snd (tail z)-   where-    z = map (lubNarrow h) (undefined:t)---{-----------------------------------------------------------------------------}---- | Extension of lubNarrow to a heterogeneous list--class HLub l e | l -> e- where-  hLub :: l -> [e]--instance ( LubNarrow h h' e-         )-      => HLub (HCons h (HCons h' HNil)) 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''-         , LubNarrow e' e'' e-         , HLub (HCons e (HCons h'' t)) e-         )-      => HLub (HCons h (HCons h' (HCons h'' t))) e- where-  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------ Decide if two records r1 and r2 are identical or differ only in the order--- of their fields.------ If the two record types are indeed equivalent, return the witness of--- their equivalence, (HJust (r1->r2,r2->r1)). If they are not equivalent,--- return HNothing------ The function equivR does not examine the values of its arguments:--- it needs only their types.--------- The algorithm is simple: two records are equivalent if one can be narrowed--- to the other, and vice versa. The narrowing coercions are the desired--- witnesses.------ The obvious optimization is to check first if two records are of the same--- type. That requires TypeEq however. Perhaps we shouldn't use it here.--- Use of the record narrowing tacitly assumes that the label of a record--- 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-    equivR :: Record r1 -> Record r2 -> res---{--instance (TypeEq r1 r2 b, RecordEquiv' b r1 r2 res)-    => RecordEquiv r1 r2 res where-    equivR _ _ = equivR' (undefined::b) (undefined::r1) (undefined::r2)--- Two records have the same type: the fast path-instance RecordEquiv' HTrue r r-                      (HJust (Record r->Record r,Record r->Record r)) where-    equivR' _ _ _ = HJust (id,id)--}--instance (NarrowM r1 r2 r12, NarrowM r2 r1 r21,-          RecordEquiv' (Record r1->r12) (Record r2->r21) res)-    => RecordEquiv r1 r2 res where-    equivR r1 r2 = equivR' r1p r2p-     where r1p (r1 :: Record r1) = narrowM r1 r2-           r2p (r2 :: Record r2) = narrowM r2 r1--class RecordEquiv' pj1 pj2 res | pj1 pj2 -> res where-    equivR' :: pj1 -> pj2 -> res--instance RecordEquiv' (r1->HJust r2) (r2->HJust r1) (HJust (r1->r2,r2->r1))-    where-    equivR' r12 r21 = HJust (unj.r12,unj.r21)-     where unj (HJust x) = x---- r2 has something that r1 doesn't-instance RecordEquiv' (r1->HNothing) pj2 HNothing where-    equivR' _ _ = HNothing---- r1 is a strict superset of r2-instance RecordEquiv' (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 (_::Proxy x)-   = mkTyConApp proxyTcName [ typeOf (undefined::x) ]---{-----------------------------------------------------------------------------}-
− Data/HList/GhcSyntax.hs 
@@ -1,164 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{- |-   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Some dedicated infix operators at the type and the value level.--}--module Data.HList.GhcSyntax where--import Data.HList.FakePrelude-import Data.HList.HListPrelude-import Data.HList.Record-import Data.HList.GhcRecord-import Data.HList.HArray---{-----------------------------------------------------------------------------}---- * For types--infixr 2 :*:-infixr 2 .*.--type e :*: l = HCons e l---infixr 4 :=:-type l :=: v = LVPair l v--infixr 4 .=.---{-----------------------------------------------------------------------------}---- * For records--{-|--  [@(.*.)@]-           Add a field to a record. Analagous to (++) for-           lists.--  > record .*. field1-  >        .*. field2---}-(.*.) :: HExtend e l l' => e -> l -> l'-(.*.) =  hExtend--{-|--  Create a value with the given label. Analagous to a data-  constructor such as 'Just', 'Left', or 'Right'. Higher fixity-  than record-modification operations like (.*.), (.-.), etc. to-  support expression like the below w/o parentheses:--  > label1 .=. value1 .*.-  > label2 .=. value2 .*.-  > emptyRecord---}-(.=.) :: l -> v -> LVPair l v-l .=. v = newLVPair l v--infixr 9 .!.-{-|-  Lookup a value in a record, by its label. Analagous to (!!), the-  list indexing operation. Highest fixity, like (!!).--  > record1 .*. label1 .=. record2 .!. label1-  >         .*. label2 .=. record2 .!. label2---}-(.!.) :: (HasField l r v) => r -> l -> v-r .!. l =  hLookupByLabel l r--infixl 2 .-.-{-|-  Remove a field from a record. At the same-  level as other record modification options (.*.). Analagous-  to (\\) in lists.--  > record1 .-. label1--  > label1 .=. value1 .*.-  > label2 .=. value2 .-.-  > label2 .*.-  > emptyRecord--  > label1 .=. value1 .-.-  > label1 .*.-  > label2 .=. value2 .*.-  > emptyRecord--  > record1 .*. label1 .=. record2 .!. label1-  >         .*. label2 .=. record2 .!. label2-  >         .-. label1---}-(.-.) :: (H2ProjectByLabels (HCons e HNil) r _r' r') =>-    Record r -> e -> Record r'-r .-. l =  hDeleteAtLabel l r--infixr 2 .@.-{-|--  Update a field with a particular value.-  Same fixity as (.*.) so that extensions and updates can be chained.-  There is no real list analogue, since there is no Prelude defined-  update.--  > label1 .=. value1 .@. record1---}-(.@.) :: (HUpdateAtHNat n (LVPair t t1) t2 l',HFind t ls n,RecordLabels t2 ls) =>LVPair t t1 -> Record t2 -> Record l'-f@(LVPair v) .@. r  =  hUpdateAtLabel (labelLVPair f) v r--infixr 2 .^.-{-|-  This is a variation on updating (according to GhcRecord.hs),-  so use the same fixity as (.\@.).--}-(.^.) :: (HUpdateAtHNat n (LVPair t t1) t2 l',HFind t ls n,RecordLabels t2 ls,HasField t t2 (Proxy t1)) =>LVPair t t1 -> Record t2 -> Record l'-f@(LVPair v) .^. r = hUnproxyLabel (labelLVPair f) v r--infixr 2 .<.-{-|-  Another variation on update, so give it the same fixity as (.\@.).---}-(.<.) :: (HasField t t2 t1,HUpdateAtHNat n (LVPair t t1) t2 l',HFind t ls n,RecordLabels t2 ls) =>LVPair t t1 -> Record t2 -> Record l'-f@(LVPair v) .<. r = hTPupdateAtLabel (labelLVPair f) v r--infixl 1 .<++.-{-|-  Similar to list append, so give this slightly lower fixity than-  (.*.), so we can write:--   > field1 .=. value .*. record1 .<++. record2---}-(.<++.) ::  (HLeftUnion r r' r'') => r -> r' -> r''-r .<++. r' = hLeftUnion r r'---{-----------------------------------------------------------------------------}---- Convenience notation for TIRs--infixr 2 :+:-infixr 2 .+.--type e :+: l = HCons (Proxy e) l--{-|-  Type-indexed rows append. Very similar to (.*.), so-  keep the same fixity.--}-(.+.) ::  (HExtend (Proxy e) l l') => e -> l -> l'-e .+. r = hExtend (toProxy e) r---{-----------------------------------------------------------------------------}
Data/HList/HArray.hs view
@@ -1,6 +1,4 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  FlexibleContexts, UndecidableInstances #-}+ {- |    The HList library @@ -12,232 +10,204 @@ module Data.HList.HArray where  import Data.HList.FakePrelude-import Data.HList.HListPrelude+import Data.HList.HList  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- * Lookup -class HNat n => HLookupByHNat n l e | n l -> e- where-  hLookupByHNat :: n -> l -> e+class HLookupByHNat (n :: HNat) (l :: [*]) where+  type HLookupByHNatR (n :: HNat) (l :: [*]) :: *+  hLookupByHNat :: Proxy n -> HList l -> HLookupByHNatR n l -instance HLookupByHNat HZero (HCons e l) e- where-  hLookupByHNat _ (HCons e _) = e+instance HLookupByHNat HZero (e ': l) where+  type HLookupByHNatR HZero (e ': l) = e+  hLookupByHNat _ (HCons e _)        = e -instance (HLookupByHNat n l e', HNat n)-      => HLookupByHNat (HSucc n) (HCons e l) e'- where+instance HLookupByHNat n l => HLookupByHNat (HSucc n) (e ': l) where+  type HLookupByHNatR (HSucc n) (e ': l) = HLookupByHNatR n l   hLookupByHNat n (HCons _ l) = hLookupByHNat (hPred n) l  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- * Delete -class HNat n => HDeleteAtHNat n l l' | n l -> l'- where-  hDeleteAtHNat :: n -> l -> l'+class HDeleteAtHNat (n :: HNat) (l :: [*]) where+  type HDeleteAtHNatR (n :: HNat) (l :: [*]) :: [*]+  hDeleteAtHNat :: Proxy n -> HList l -> HList (HDeleteAtHNatR n l) -instance HDeleteAtHNat HZero (HCons e l) l- where-  hDeleteAtHNat _ (HCons _ l) = l+instance HDeleteAtHNat HZero (e ': l) where+  type HDeleteAtHNatR  HZero (e ': l) = l+  hDeleteAtHNat _ (HCons _ l)         = l -instance (HDeleteAtHNat n l l', HNat n)-      => HDeleteAtHNat (HSucc n) (HCons e l) (HCons e l')- where+instance HDeleteAtHNat n l => HDeleteAtHNat (HSucc n) (e ': l) where+  type HDeleteAtHNatR  (HSucc n) (e ': l) = e ': (HDeleteAtHNatR n l)   hDeleteAtHNat n (HCons e l) = HCons e (hDeleteAtHNat (hPred n) l)  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- * Update+class HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where+    hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) -class HNat n => HUpdateAtHNat n e l l' | n e l -> l', l' n -> e- where-  hUpdateAtHNat :: n -> e -> l -> l'+instance HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where+    hUpdateAtHNat = hUpdateAtHNat' (Proxy :: Proxy l) -instance HUpdateAtHNat HZero e' (HCons e l) (HCons e' l)- where-  hUpdateAtHNat _ e' (HCons _ l) = HCons e' l+class HUpdateAtHNat' (n :: HNat) e (l :: [*]) (l0 :: [*]) where+  type HUpdateAtHNatR (n :: HNat) e (l :: [*]) :: [*]+  hUpdateAtHNat' :: Proxy l0 -> Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) -instance (HUpdateAtHNat n e' l l', HNat n)-      => HUpdateAtHNat (HSucc n) e' (HCons e l) (HCons e l')- where-  hUpdateAtHNat n e' (HCons e l)-   = HCons e (hUpdateAtHNat (hPred n) e' l)+instance HUpdateAtHNat' HZero e1 (e ': l) l0 where+  type HUpdateAtHNatR  HZero e1 (e ': l) = e1 ': l+  hUpdateAtHNat' _ _ e1 (HCons _ l)      = HCons e1 l +instance HUpdateAtHNat' n e1 l l0 => HUpdateAtHNat' (HSucc n) e1 (e ': l) l0 where+  type HUpdateAtHNatR  (HSucc n) e1 (e ': l) = e ': (HUpdateAtHNatR n e1 l)+  hUpdateAtHNat' l0 n e1 (HCons e l) = HCons e (hUpdateAtHNat' l0 (hPred n) e1 l) -{-----------------------------------------------------------------------------}+instance Fail (HNatIndexTooLarge n HList l0) => HUpdateAtHNat' n e1 '[] l0 where+  type HUpdateAtHNatR n e1 '[] = '[]+  hUpdateAtHNat' _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances" --- * Splitting--- | Splitting an array according to indices------ Signature is inferred:------  > hSplitByHNats :: (HSplitByHNats' ns l' l'1 l'', HMap (HAddTag HTrue) l l') =>---  >               ns -> l -> (l'1, l'')-hSplitByHNats ns l = hSplitByHNats' ns (hFlag l)+-- --------------------------------------------------------------------------+-- * Projection -class HNats ns => HSplitByHNats' ns l l' l'' | ns l -> l' l''- where-  hSplitByHNats' :: ns -> l -> (l',l'')+-- One way of implementing it: -instance HSplit l l' l''-      => HSplitByHNats' HNil l HNil l'- where-  hSplitByHNats' HNil l = (HNil,l')-   where-    (l',_) = hSplit l+hProjectByHNats' ns l = hMap (FHLookupByHNat l) ns -instance ( HLookupByHNat n l (e,b)-         , HUpdateAtHNat n (e,HFalse) l l'''-         , HSplitByHNats' ns l''' l' l''-         )-      =>   HSplitByHNats' (HCons n ns) l (HCons e l') l''- where-  hSplitByHNats' (HCons n ns) l = (HCons e l',l'')-   where-    (e,_)    = hLookupByHNat  n l-    l'''     = hUpdateAtHNat  n (e,hFalse) l-    (l',l'') = hSplitByHNats' ns l'''+newtype FHLookupByHNat (l :: [*]) = FHLookupByHNat (HList 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 -{-----------------------------------------------------------------------------}+-- The drawback is that the list ns must be a constructed value.+-- We cannot lazily pattern-match on GADTs. Moreover, there are+-- repeated traversals of the HList l at run-time. --- * Projection+-- Here is a more optimal version with a better separation of+-- 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.+-- We traverse the HList l only once. The lookup in the list of+-- indices is compile-time only.+-- (In contrast, hProjectByHNats' does not ignore duplicates).+-- 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+-- ns are to be included in the result), whereas hProjectByHNats+-- corresponds to set = False. -class HNats ns => HProjectByHNats ns l l' | ns l -> l'- where-  hProjectByHNats :: ns -> l -> l'+hProjectByHNats (_ :: Proxy (ns :: [HNat])) l =+    hUnfold (FHUProj :: FHUProj True ns) (l,hZero) -instance HProjectByHNats HNil HNil HNil- where-  hProjectByHNats _ _ = HNil+data FHUProj (sel :: Bool) (ns :: [HNat]) = FHUProj -instance HProjectByHNats HNil (HCons e l) HNil- where-  hProjectByHNats _ _ = HNil+instance Apply (FHUProj sel ns) (HList '[],n) where+    type ApplyR (FHUProj sel ns) (HList '[],n) = HNothing+    apply _ _ = HNothing -instance ( HLookupByHNat n (HCons e l) e'-         , HProjectByHNats ns (HCons e l) l'-         )-         => HProjectByHNats (HCons n ns) (HCons e l) (HCons e' l')- where-  hProjectByHNats (HCons n ns) l = HCons e' l'-   where e' = hLookupByHNat n l-         l' = hProjectByHNats ns l+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) =+       ApplyR (Proxy (HBoolEQ sel (KMember n ns)), FHUProj sel ns)+              (HList (e ': l),Proxy n)+    apply fn s = apply (Proxy::ch,fn) s +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))))+    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)+          (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))+    apply (_,fn) (HCons _ l,n) = apply fn (l,hSucc n) --- * Complement of Projection -class HProjectAwayByHNats ns l l' | ns l -> l'- where-  hProjectAwayByHNats :: ns -> l -> l'--instance ( HLength l len-         , HBetween len nats-         , HDiff nats ns ns'-         , HProjectByHNats ns' l l'-         )-           => HProjectAwayByHNats ns l l'- where-  hProjectAwayByHNats ns l = l'-   where-    len  = hLength l-    nats = hBetween len-    ns'  = hDiff nats ns-    l'   = hProjectByHNats ns' l-+-- lifted member on naturals+type family KMember (n :: HNat) (ns :: [HNat]) :: Bool+type instance KMember n '[]       = False+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 :: [*]) =+    HUnfold (FHUProj True ns) (HList l, Proxy 'HZero) --- * Enumerate naturals--- | from 1 to x - 1+type HProjectByHNatsCtx ns l =+  (Apply (FHUProj True ns) (HList l, Proxy 'HZero),+      HUnfold' (FHUProj True ns)+       (HList l, Proxy 'HZero)+    ) -class HBetween x y | x -> y- where-  hBetween :: x -> y+-- * Complement of Projection -instance HBetween (HSucc HZero) (HCons HZero HNil)- where-  hBetween _ = HCons hZero HNil+-- The naive approach is repeated deletion (which is a bit subtle+-- sine we need to adjust indices)+-- 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. -instance ( HNat x-         , HBetween (HSucc x) y-         , HAppend y (HCons (HSucc x) HNil) z-         , HList y-         )-           => HBetween (HSucc (HSucc x)) z- where-  hBetween x = hBetween (hPred x) `hAppend` HCons (hPred x) HNil+hProjectAwayByHNats (_ :: Proxy (ns :: [HNat])) l =+    hUnfold (FHUProj :: FHUProj False ns) (l,hZero)  --- * Set-difference on naturals--class HDiff x y z | x y -> z- where-  hDiff :: x -> y -> z+-- Useful abbreviations for complex types (which are inferred)+type HProjectAwayByHNatsR (ns :: [HNat]) (l :: [*]) =+    HUnfold (FHUProj False ns) (HList l, Proxy 'HZero) -instance HDiff HNil x HNil- where-  hDiff _ _ = HNil+type HProjectAwayByHNatsCtx ns l =+  (Apply (FHUProj False ns) (HList l, Proxy 'HZero),+      HUnfold' (FHUProj False ns) (HList l, Proxy 'HZero)+  ) -instance ( HOrdMember e y b-         , HDiff x y z-         , HCond b z (HCons e z) z'-         )-           => HDiff (HCons e x) y z'- where-  hDiff (HCons e x) y = z'-   where z' = hCond b z (HCons e z)-         b  = hOrdMember e y-         z  = hDiff x y+-- * Splitting+-- | Splitting an array according to indices +-- The following is not optimal; we'll optimize later if needed --- * Membership test for types with 'HOrd' instances--- |--- This special type equality/comparison is entirely pure!+hSplitByHNats ns l = (hProjectByHNats ns l,+                      hProjectAwayByHNats ns l)+{-+hSplitByHNats ns l = hSplitByHNats' ns (hFlag l) -class HOrdMember e l b | e l -> b+class HNats ns => HSplitByHNats' ns l l' l'' | ns l -> l' l''  where-  hOrdMember :: e -> l -> b+  hSplitByHNats' :: ns -> l -> (l',l'') -instance HOrdMember e HNil HFalse+instance HSplit l l' l''+      => HSplitByHNats' HNil l HNil l'  where-  hOrdMember _ _ = hFalse+  hSplitByHNats' HNil l = (HNil,l')+   where+    (l',_) = hSplit l -instance ( HEq e e' b1-         , HOrdMember e l b2-         , HOr b1 b2 b+instance ( HLookupByHNat n l (e,b)+         , HUpdateAtHNat n (e,HFalse) l l'''+         , HSplitByHNats' ns l''' l' l''          )-           => HOrdMember e (HCons e' l) b+      =>   HSplitByHNats' (HCons n ns) l (HCons e l') l''  where-  hOrdMember e (HCons e' l) = hOr b1 b2+  hSplitByHNats' (HCons n ns) l = (HCons e l',l'')    where-    b1 = hEq e e'-    b2 = hOrdMember e l---{-----------------------------------------------------------------------------}---- * Length--class (HList l, HNat n) => HLength l n | l -> n-instance HLength HNil HZero-instance (HLength l n, HNat n, HList l)-      => HLength (HCons a l) (HSucc n)--hLength   :: HLength l n => l -> n-hLength _ =  undefined+    (e,_)    = hLookupByHNat  n l+    l'''     = hUpdateAtHNat  n (e,hFalse) l+    (l',l'') = hSplitByHNats' ns l'''+-}  -{-----------------------------------------------------------------------------}+{- +-- -------------------------------------------------------------------------- -- * Bounded lists  class HMaxLength l s@@ -252,5 +222,4 @@ hSingle :: (HSingleton l, HHead l e) => l -> e hSingle = hHead --{-----------------------------------------------------------------------------}+-}
+ 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
@@ -0,0 +1,1657 @@+{-# LANGUAGE CPP #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Basic declarations for typeful heterogeneous lists.++ -}++module Data.HList.HList where++import Data.HList.FakePrelude+import Data.HList.HListPrelude++import Text.ParserCombinators.ReadP+import Data.List++import LensDefs++import Data.Array (Ix)++#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup+#endif++-- --------------------------------------------------------------------------+-- * Heterogeneous type sequences+{- $note++There are three sensible ways to define HLists:++@+data HList (l::[*]) where+    HNil  :: HList '[]+    HCons :: e -> HList l -> HList (e ': l)+@++This ensures that sequences can only be formed with Nil+and Cons. The argument to HList is a promoted lists (kind @[*]@),+which has a more attractive syntax.+++Earlier versions of HList used an algebraic data type:++@+data HCons a b = HCons a b+data HNil = HNil+@++Disadvantages:++* values with types like @HCons Int Double@ to be created,+  which are nonsense to the functions in HList++* some recursive functions do not need a class with the GADT. For example:++  @+    hInit :: HListGADT (x ': xs) -> HListGADT (HInit (x ': xs))+    hInit (HCons x xs@(HCons _ _)) = HCons x (hInit xs)+    hInit (HCons _ HNil) = HNil++    type family HInit (xs :: [k]) :: [k]+  @++  but without the GADT, 'hInit' is written as in a class,+  which complicates inferred types+++Advantages++* lazy pattern matches are allowed, so lazy pattern matching+  on a value @undefined :: HList [a,b,c]@ can create the+  spine of the list. 'hProxies' avoids the use of 'undefined',+  but a slightly more complicated class context has to be written+  or inferred.++* type inference is better if you want to directly pattern match+<http://stackoverflow.com/questions/19077037/is-there-any-deeper-type-theoretic-reason-ghc-cant-infer-this-type see stackoverflow post here>++* better pattern exhaustiveness checking (as of ghc-7.8)++* standalone deriving works++* Data.Coerce.coerce works because the parameters have role representational,+  not nominal as they are for the GADT and data family. Probably the GADT/type+  family actually do have a representational role:+  <http://stackoverflow.com/questions/24222552/does-this-gadt-actually-have-type-role-representational>++++The data family version (currently used) gives the same type constructor+@HList :: [*] -> *@ as the GADT, while pattern matching behaves+like the algebraic data type. Furthermore, nonsense values like+@HCons 1 2 :: HCons Int Int@ cannot be written with the data family.++A variation on the data family version is++> data instance HList '[] = HNil+> newtype instance HList (x ': xs) = HCons1 (x, HList xs)+> pattern HCons x xs = HCons1 (x, xs)++This allows HList to have a nominal role, but on the other+hand the PatternSynonym is not supported with ghc-7.6 and+exhaustiveness checking is not as good (warnings for _ being+unmatched)++-}+++data family HList (l::[*])++data instance HList '[] = HNil+data instance HList (x ': xs) = x `HCons` HList xs++deriving instance Eq (HList '[])+deriving instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs))++deriving instance Ord (HList '[])+deriving instance (Ord x, Ord (HList xs)) => Ord (HList (x ': xs))++deriving instance Ix (HList '[])+deriving instance (Ix x, Ix (HList xs)) => Ix (HList (x ': xs))++deriving instance Bounded (HList '[])+deriving instance (Bounded x, Bounded (HList xs)) => Bounded (HList (x ': xs))+++-- Enum cannot be derived+++-- | creates a HList of Proxies++class HProxiesFD (xs :: [*]) pxs | pxs -> xs -- DropProxy pxs ~ xs+                      , xs -> pxs -- AddProxy xs ~ pxs+      where hProxies :: HList pxs++{- Ideally we could write:++> class DropProxy (AddProxy xs) ~ xs => HProxies xs where+>     hProxies :: HList (AddProxy xs)++See https://ghc.haskell.org/trac/ghc/ticket/10009 -}+type HProxies xs = HProxiesFD xs (AddProxy xs)+++{- | Add 'Proxy' to a type++>>> let x = undefined :: HList (AddProxy [Char,Int])+>>> :t x+x :: HList '[Proxy Char, Proxy Int]+++-}+type family AddProxy (xs :: k) :: k+type instance AddProxy '[] = '[]+type instance AddProxy (x ': xs) = AddProxy x ': AddProxy xs+type instance AddProxy (x :: *) = Proxy x++-- | inverse of 'AddProxy'+type family DropProxy (xs :: k) :: k+type instance DropProxy (x ': xs) = DropProxy x ': DropProxy xs+type instance DropProxy '[] = '[]+type instance DropProxy (Proxy x) = x++instance HProxiesFD '[] '[] where+    hProxies = HNil++instance (HProxiesFD xs pxs) => HProxiesFD (x ': xs) (Proxy x ': pxs) where+    hProxies = Proxy `HCons` hProxies++++instance Show (HList '[]) where+    show _ = "H[]"++instance (Show e, Show (HList l)) => Show (HList (e ': l)) where+    show (HCons x l) =+      case show l of+        'H':'[':s -> "H[" ++ show x ++ (if s == "]" then s else "," ++ s)+        s -> error $ "unreachable branch: " ++ show x ++ " " ++ s++instance Read (HList '[]) where+    readsPrec _ str = case stripPrefix "H[]" str of+                        Nothing -> []+                        Just rest -> [(HNil, rest)]++instance+   (HProxies l, Read e,+    HSequence ReadP (ReadP e ': readP_l) (e ': l),+    HMapCxt HList ReadElement (AddProxy l) readP_l)  =>+      Read (HList (e ': l)) where+  readsPrec _ = readP_to_S $ do+    _ <- string "H["+    l <- return (hProxies :: HList (AddProxy l))+    let parsers = readS_to_P reads `HCons` hMap ReadElement l+    hlist <- hSequence parsers+    _ <- string "]"+    return hlist+++-- similar to ReadComponent used to define instance Read Record+data ReadElement = ReadElement++instance (y ~ ReadP x, Read x) => ApplyAB ReadElement (Proxy x) y where+    applyAB ReadElement _ = do+      _ <- string ","+      readS_to_P reads+++infixr 2 `HCons`+++-- --------------------------------------------------------------------------+-- * Basic list functions++-- | 'head'+hHead :: HList (e ': l) -> e+hHead (HCons x _) = x++-- | 'tail'+hTail :: HList (e ': l) -> HList l+hTail (HCons _ l) = l++-- | 'last'+hLast xs = hHead (hReverse_ xs)+++class HInit xs where+    type HInitR xs :: [*]+    hInit :: HList xs -> HList (HInitR xs)++instance HInit '[x] where+    type HInitR '[x] = '[]+    hInit _ = HNil++instance HInit (b ': c) => HInit (a ': b ': c) where+    type HInitR (a ': b ': c) = a ': HInitR (b ': c)+    hInit (a `HCons` bc) = a `HCons` hInit bc+++-- | Length, but see 'HLengthEq' instead+type family HLength (x :: [k]) :: HNat+type instance HLength '[] = HZero+type instance HLength (x ': xs) = HSucc (HLength xs)++hLength   :: HLengthEq l n => HList l -> Proxy n+hLength _ =  Proxy++-- ** Append+instance HExtend e (HList l) where+  type HExtendR e (HList l) = HList (e ': l)+  (.*.) = HCons++instance HAppendList l1 l2 => HAppend (HList l1) (HList l2) where+  hAppend = hAppendList+type instance HAppendR (HList l1) (HList l2) = HList (HAppendListR l1 l2)++type family HAppendListR (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HAppendListR '[] l = l+type instance HAppendListR (e ': l) l' = e ': HAppendListR l l'+++class HAppendList l1 l2 where+  -- | the same as 'hAppend'+  hAppendList :: HList l1 -> HList l2 -> HList (HAppendListR l1 l2)++instance HAppendList '[] l2 where+  hAppendList HNil l = l++instance HAppendList l l' => HAppendList (x ': l) l' where+  hAppendList (HCons x l) l' = HCons x (hAppendList l l')++-- --------------------------------------------------------------------------++-- ** Alternative append+++-- | 'hAppend'' below is implemented using the same idea+append' :: [a] -> [a] -> [a]+append' l l' = foldr (:) l' l++-- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr'+hAppend' :: (HFoldr FHCons v l r) => HList l -> v -> r+hAppend' l l' = hFoldr FHCons l' l++data FHCons = FHCons++instance ( x ~ (e,HList l), y ~ (HList (e ': l))) => ApplyAB FHCons x y  where+    applyAB _ (e,l) = HCons e l+++-- ** Historical append++{- $++The original HList code is included below. In both cases+we had to program the algorithm twice, at the term and the type levels.++[@The class HAppend@]++> class HAppend l l' l'' | l l' -> l''+>  where+>   hAppend :: l -> l' -> l''+>++[@The instance following the normal append@]++> instance HList l => HAppend HNil l l+>  where+>   hAppend HNil l = l+>+> instance (HList l, HAppend l l' l'')+>       => HAppend (HCons x l) l' (HCons x l'')+>  where+>   hAppend (HCons x l) l' = HCons x (hAppend l l')++-}++-- --------------------------------------------------------------------------+-- * Reversing HLists++-- Append the reversed l1 to l2+type family HRevAppR (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HRevAppR '[] l = l+type instance HRevAppR (e ': l) l' = HRevAppR l (e ': l')+++class HRevApp l1 l2 l3 | l1 l2 -> l3 where+    hRevApp :: HList l1 -> HList l2 -> HList l3++instance HRevApp '[] l2 l2 where+    hRevApp _ l = l++instance HRevApp l (x ': l') z => HRevApp (x ': l) l' z where+    hRevApp (HCons x l) l' = hRevApp l (HCons x l')++++class HReverse xs sx | xs -> sx, sx -> xs where+    hReverse :: HList xs -> HList sx++instance (HRevApp xs '[] sx,+          HRevApp sx '[] xs) => HReverse xs sx where+    hReverse l = hRevApp l HNil++-- | a version of 'hReverse' that does not allow the type+-- information to flow backwards+hReverse_ l = hRevApp l HNil++-- --------------------------------------------------------------------------++--+-- * A nicer notation for lists+--+++-- | List termination+hEnd :: HList l -> HList l+hEnd = id++{- ^+   Note:++        [@x :: HList a@] means: @forall a. x :: HList a@++        [@hEnd x@] means: @exists a. x :: HList a@+-}+++-- |  Building lists++hBuild :: (HBuild' '[] r) => r+hBuild =  hBuild' HNil++class HBuild' l r where+    hBuild' :: HList l -> r++instance HReverse l l'+      => HBuild' l (HList l') where+  hBuild' l = hReverse l++instance HBuild' (a ': l) r+      => HBuild' l (a->r) where+  hBuild' l x = hBuild' (HCons x l)++-- ** examples+{- $examplesNote++The classes above allow the third (shortest) way to make a list+(containing a,b,c) in this case++> list = a `HCons` b `HCons` c `HCons` HNil+> list = a .*. b .*. c .*. HNil+> list = hEnd $ hBuild a b c++>>> let x = hBuild True in hEnd x+H[True]++>>> let x = hBuild True 'a' in hEnd x+H[True,'a']++>>> let x = hBuild True 'a' "ok" in hEnd x+H[True,'a',"ok"]++hBuild can also produce a Record, such that++> hBuild x y ^. from unlabeled++can also be produced using++@+'hEndR' $ hBuild x y+@++-}++-- *** historical+{- $hbuild the show instance has since changed, but these uses of+'hBuild'/'hEnd' still work++> HList> let x = hBuild True in hEnd x+> HCons True HNil++> HList> let x = hBuild True 'a' in hEnd x+> HCons True (HCons 'a' HNil)++> HList> let x = hBuild True 'a' "ok" in hEnd x+> HCons True (HCons 'a' (HCons "ok" HNil))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5))+> HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus+> True++-}++-- --------------------------------------------------------------------------++-- * folds+-- ** foldr+-- $foldNote  Consume a heterogenous list.+++class HFoldr f v (l :: [*]) r where+    hFoldr :: f -> v -> HList l -> r++instance (v ~ v') => HFoldr f v '[] v' where+    hFoldr       _ v _   = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr f v l r)+    => HFoldr f v (e ': l) r' where+    hFoldr f v (HCons x l)    = applyAB f (x, hFoldr f v l :: r)+++class HScanr f z ls rs where+    hScanr :: f -> z -> HList ls -> HList rs++instance lz ~ '[z] => HScanr f z '[] lz where+    hScanr _ z _ = HCons z HNil++instance (ApplyAB f (x,r) s, HScanr f z xs (r ': rs),+          srrs ~ (s ': r ': rs)) => HScanr f z (x ': xs) srrs where+    hScanr f z (HCons x xs) =+        case hScanr f z xs :: HList (r ': rs) of+            HCons r rs -> (applyAB f (x,r) :: s) `HCons` r `HCons` rs++class HFoldr1 f (l :: [*]) r where+    hFoldr1 :: f -> HList l -> r++instance (v ~ v') => HFoldr1 f '[v] v' where+    hFoldr1      _ (HCons v _)  = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr1 f (e' ': l) r)+    => HFoldr1 f (e ': e' ': l) r' where+    hFoldr1 f (HCons x l)    = applyAB f (x, hFoldr1 f l :: r)+++-- ** foldl++{- | like 'foldl'+++>>> hFoldl (uncurry $ flip (:)) [] (1 `HCons` 2 `HCons` HNil)+[2,1]+++-}+class HFoldl f (z :: *) xs (r :: *) where+    hFoldl :: f -> z -> HList xs -> r++instance (zx ~ (z,x), ApplyAB f zx z', HFoldl f z' xs r)+    => HFoldl f z (x ': xs) r where+    hFoldl f z (x `HCons` xs) = hFoldl f (applyAB f (z,x) :: z') xs++instance (z ~ z') => HFoldl f z '[] z' where+    hFoldl _ z _ = z++++++-- * unfolds++-- ** unfold+-- $unfoldNote Produce a heterogenous list. Uses the more limited+-- 'Apply' instead of 'App' since that's all that is needed for uses of this+-- function downstream. Those could in principle be re-written.++-- hUnfold :: (Apply p s, HUnfold' p s) => p -> s -> HList (HUnfold p s)+hUnfold p s = hUnfold' p (apply p s)++type HUnfold p s = HUnfoldR p (ApplyR p s)++type family HUnfoldR p res :: [*]+type instance HUnfoldR p HNothing = '[]+type instance HUnfoldR p (HJust (e,s)) = e ': HUnfoldR p (ApplyR p s)++type HUnfold' p res = HUnfoldFD p (ApplyR p res) (HUnfold p res)++class HUnfoldFD p res z | p res -> z where+    hUnfold' :: p -> res -> HList z++instance HUnfoldFD p HNothing '[] where+    hUnfold' _ _ = HNil++instance (Apply p s, HUnfoldFD p (ApplyR p s) z) => HUnfoldFD p (HJust (e,s)) (e ': z) where+    hUnfold' p (HJust (e,s)) = HCons e (hUnfold p s)+++-- ** replicate++{- |++Sometimes the result type can fix the type of the+first argument:++>>> hReplicate Proxy () :: HList '[ (), (), () ]+H[(),(),()]++However, with HReplicate all elements must have the same type, so it may be+easier to use 'HList2List':++>>> list2HList (repeat 3) :: Maybe (HList [Int, Int, Int])+Just H[3,3,3]++-}+class HLengthEq es n => HReplicateFD (n :: HNat) e es+          | n e -> es, es -> n where+    hReplicate :: Proxy n -> e -> HList es++instance HReplicateFD HZero e '[] where+    hReplicate _ _ = HNil++instance (HReplicateFD n e es, e ~ e') => HReplicateFD (HSucc n) e (e' ': es) where+    hReplicate n e = e `HCons` hReplicate (hPred n) e++type HReplicate n e = HReplicateFD n e (HReplicateR n e)++-- | would be associated with 'HReplicate' except we want+-- it to work with `e` of any kind, not just `*` that you can+-- put into a HList. An \"inverse\" of 'HLength'+type family HReplicateR (n :: HNat) (e :: k) :: [k]+type instance HReplicateR HZero e = '[]+type instance HReplicateR (HSucc n) e = e ': HReplicateR n e++{- | HReplicate produces lists that can be converted to ordinary+lists++>>> let two = hSucc (hSucc hZero)+>>> let f = Fun' fromInteger :: Fun' Num Integer++>>> :t applyAB f+applyAB f :: Num b => Integer -> b++>>> hReplicateF two f 3+H[3,3]++>>> hReplicateF Proxy f 3 :: HList [Int, Double, Integer]+H[3,3.0,3]++-}+class HLengthEq r n => HReplicateF (n :: HNat) f z r | r -> n where+    hReplicateF :: HLengthEq r n => Proxy n -> f -> z -> HList r++instance HReplicateF HZero f z '[] where+    hReplicateF _ _ _ = HNil++instance (ApplyAB f z fz,+          HReplicateF n f z r')+  => HReplicateF (HSucc n) f z (fz ': r') where+    hReplicateF n f z = applyAB f z `HCons` hReplicateF (hPred n) f z++-- ** iterate+{- |++This function behaves like 'iterate', with an extra+argument to help figure out the result length++>>> let three = hSucc (hSucc (hSucc hZero))+>>> let f = Fun Just :: Fun '() Maybe++>>> :t applyAB f+applyAB f :: a -> Maybe a++f is applied to different types:++>>> hIterate three f ()+H[(),Just (),Just (Just ())]++It is also possible to specify the length later on,+as done with Prelude.'iterate'++>>> let take3 x | _ <- hLength x `asTypeOf` three = x+>>> take3 $ hIterate Proxy f ()+H[(),Just (),Just (Just ())]++-}+class HLengthEq r n => HIterate n f z r where+    hIterate :: HLengthEq r n => Proxy n -> f -> z -> HList r++instance HIterate HZero f z '[] where+    hIterate _ _ _ = HNil++instance (ApplyAB f z z',+      HIterate n f z' r',+      z ~ z_)+     => HIterate (HSucc n) f z (z_ ': r') where+    hIterate n f z = z `HCons` hIterate (hPred n) f (applyAB f z :: z')++-- * concat++{- |++Like 'concat' but for HLists of HLists.++Works in ghci... puzzling as what is different in doctest (it isn't+@-XExtendedDefaultRules@)++>>> let a = hEnd $ hBuild 1 2 3+>>> let b = hEnd $ hBuild 'a' "abc"+>>> hConcat $ hBuild a b+H[1,2,3,'a',"abc"]++-}+type HConcat xs = HConcatFD xs (HConcatR xs)++hConcat :: HConcat xs => HList xs -> HList (HConcatR xs)+hConcat x = hConcatFD x++type family HConcatR (a :: [*]) :: [*]+type instance HConcatR '[] = '[]+type instance HConcatR (x ': xs) = HAppendListR (UnHList x) (HConcatR xs)++type family UnHList a :: [*]+type instance UnHList (HList a) = a++-- for the benefit of ghc-7.10.1+class HConcatFD xxs xs | xxs -> xs+    where hConcatFD :: HList xxs -> HList xs++instance HConcatFD '[] '[] where+    hConcatFD _ = HNil++instance (HConcatFD as bs, HAppendFD a bs cs) => HConcatFD (HList a ': as) cs where+    hConcatFD (HCons x xs) = x `hAppendFD` hConcatFD xs++class HAppendFD a b ab | a b -> ab where+    hAppendFD :: HList a -> HList b -> HList ab++instance HAppendFD '[] b b where+    hAppendFD _ b = b++instance HAppendFD as bs cs => HAppendFD (a ': as) bs (a ': cs) where+    hAppendFD (HCons a as) bs = a `HCons` hAppendFD as bs+++-- --------------------------------------------------------------------------+-- * traversing HLists++-- ** producing HList+-- *** map+-- $mapNote It could be implemented with 'hFoldr', as we show further below++{- | hMap is written such that the length of the result list+can be determined from the length of the argument list (and+the other way around). Similarly, the type of the elements+of the list is propagated in both directions too.++>>> :set -XNoMonomorphismRestriction+>>> let xs = 1 .*. 'c' .*. HNil+>>> :t hMap (HJust ()) xs+hMap (HJust ()) xs :: Num y => HList '[HJust y, HJust Char]+++These 4 examples show that the constraint on the length (2 in this case)+can be applied before or after the 'hMap'. That inference is independent of the+direction that type information is propagated for the individual elements.+++>>> let asLen2 xs = xs `asTypeOf` (undefined :: HList '[a,b])++>>> let lr xs = asLen2 (applyAB (HMap HRead) xs)+>>> let ls xs = asLen2 (applyAB (HMap HShow) xs)+>>> let rl xs = applyAB (HMap HRead) (asLen2 xs)+>>> let sl xs = applyAB (HMap HShow) (asLen2 xs)+++>>> :t lr+lr+  :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...]++>>> :t rl+rl+  :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...]+++>>> :t ls+ls+  :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String]++>>> :t sl+sl+  :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String]++-}++newtype HMap f = HMap f++hMap f xs = applyAB (HMap f) xs++instance (HMapCxt r f a b, as ~ r a, bs ~ r b)+    => ApplyAB (HMap f) as bs where+    applyAB (HMap f) = hMapAux f+++-- | hMap constrained to HList+hMapL f xs = applyAB (HMapL f) xs++newtype HMapL f = HMapL f++instance (HMapCxt HList f a b, as ~ HList a, bs ~ HList b) => ApplyAB (HMapL f) as bs where+    applyAB (HMapL f) = hMapAux f+++class (SameLength a b, HMapAux r f a b) => HMapCxt r f a b++instance (SameLength a b, HMapAux r f a b) => HMapCxt r f a b++++class HMapAux (r :: [*] -> *) f (x :: [*]) (y :: [*]) where+  hMapAux :: SameLength x y => f -> r x -> r y++instance HMapAux HList f '[] '[] where+  hMapAux       _  _  = HNil++instance (ApplyAB f e e', HMapAux HList f l l', SameLength l l')+    => HMapAux HList f (e ': l) (e' ': l') where+  hMapAux f (HCons x l)    = applyAB f x `HCons` hMapAux f l+++++-- --------------------------------------------------------------------------++-- **** alternative implementation+-- $note currently broken++newtype MapCar f = MapCar f++-- | Same as 'hMap' only a different implementation.+hMapMapCar :: (HFoldr (MapCar f) (HList '[]) l l') =>+    f -> HList l -> l'+hMapMapCar f = hFoldr (MapCar f) HNil++instance ApplyAB f e e' => ApplyAB (MapCar f) (e,HList l) (HList (e' ': l)) where+    applyAB (MapCar f) (e,l) = HCons (applyAB f e) l+++-- --------------------------------------------------------------------------++-- *** @appEndo . mconcat . map Endo@+{- |++>>> let xs = length .*. (+1) .*. (*2) .*. HNil+>>> hComposeList xs "abc"+8+++-}+hComposeList+  :: (HFoldr Comp (a -> a) l (t -> a)) => HList l -> t -> a+hComposeList fs v0 = let r = hFoldr (Comp :: Comp) (\x -> x `asTypeOf` r) fs v0 in r+++-- --------------------------------------------------------------------------++-- *** sequence+{- |+   A heterogeneous version of++   > sequenceA :: (Applicative m) => [m a] -> m [a]++   Only now we operate on heterogeneous lists, where different elements+   may have different types 'a'.+   In the argument list of monadic values (m a_i),+   although a_i may differ, the monad 'm' must be the same for all+   elements. That's why we needed "Data.HList.TypeCastGeneric2" (currently (~)).+   The typechecker will complain+   if we attempt to use hSequence on a HList of monadic values with different+   monads.++   The 'hSequence' problem was posed by Matthias Fischmann+   in his message on the Haskell-Cafe list on Oct 8, 2006++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018708.html>++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018784.html>+ -}++class (Applicative m, SameLength a b) => HSequence m a b | a -> b, m b -> a where+    hSequence :: HList a -> m (HList b)+{- ^++[@Maybe@]++>>> hSequence $ Just (1 :: Integer) `HCons` (Just 'c') `HCons` HNil+Just H[1,'c']++>>> hSequence $  return 1 `HCons` Just  'c' `HCons` HNil+Just H[1,'c']+++[@List@]++>>> hSequence $ [1] `HCons` ['c'] `HCons` HNil+[H[1,'c']]+++-}++instance Applicative m => HSequence m '[] '[] where+    hSequence _ = pure HNil++instance (m1 ~ m, Applicative m, HSequence m as bs) =>+    HSequence m (m1 a ': as) (a ': bs) where+    hSequence (HCons a b) = liftA2 HCons a (hSequence b)++-- **** alternative implementation++-- | 'hSequence2' is not recommended over 'hSequence' since it possibly doesn't+-- allow inferring argument types from the result types. Otherwise this version+-- should do exactly the same thing.+--+-- The DataKinds version needs a little help to find the type of the+-- return HNil, unlike the original version, which worked just fine as+--+--  > hSequence l = hFoldr ConsM (return HNil) l++hSequence2 l =+    let rHNil = pure HNil `asTypeOf` (fmap undefined x)+        x = hFoldr (LiftA2 FHCons) rHNil l+    in x++++-- --------------------------------------------------------------------------+++-- --------------------------------------------------------------------------+-- ** producing homogenous lists++-- *** map (no sequencing)+-- $mapOut This one we implement via hFoldr++newtype Mapcar f = Mapcar f++instance (l ~ [e'], ApplyAB f e e', el ~ (e,l)) => ApplyAB (Mapcar f) el l where+    applyAB (Mapcar f) (e, l) = applyAB f e : l++-- A synonym for the complex constraint+type HMapOut f l e = (HFoldr (Mapcar f) [e] l [e])++-- | compare @hMapOut f@ with @'hList2List' . 'hMap' f@+hMapOut :: forall f e l. HMapOut f l e => f -> HList l -> [e]+hMapOut f l = hFoldr (Mapcar f) ([] :: [e]) l+++-- --------------------------------------------------------------------------+-- *** mapM++-- |+--+-- > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b]+--+-- Likewise for 'mapM_'.+--+-- See 'hSequence' if the result list should also be heterogenous.++hMapM   :: (Monad m, HMapOut f l (m e)) => f -> HList l -> [m e]+hMapM f =  hMapOut f++-- | GHC doesn't like its own type.+--+-- > hMapM_ :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m ()+--+-- Without explicit type signature, it's Ok. Sigh.+-- Anyway, Hugs does insist on a better type. So we restrict as follows:+--+hMapM_   :: (Monad m, HMapOut f l (m ())) => f -> HList l -> m ()+hMapM_ f =  sequence_ .  disambiguate . hMapM f+ where+  disambiguate :: [q ()] -> [q ()]+  disambiguate =  id++++++-- --------------------------------------------------------------------------+-- * Ensure a list to contain HNats only+-- | We do so constructively, converting the HList whose elements+-- are Proxy HNat to [HNat]. The latter kind is unpopulated and+-- is present only at the type level.++type family HNats (l :: [*]) :: [HNat]+type instance HNats '[] = '[]+type instance HNats (Proxy n ': l) = n ': HNats l++hNats :: HList l -> Proxy (HNats l)+hNats _ = Proxy+++-- --------------------------------------------------------------------------+-- * Membership tests++-- | Check to see if an HList contains an element with a given type+-- This is a type-level only test++class HMember (e1 :: k) (l :: [k]) (b :: Bool) | e1 l -> b+instance HMember e1 '[] False+instance (HEq e1 e b, HMember' b e1 l br) => HMember  e1 (e ': l) br+class HMember' (b0 :: Bool) (e1 :: k) (l :: [k]) (b :: Bool) | b0 e1 l -> b+instance HMember' True e1 l True+instance (HMember e1 l br) => HMember' False e1 l br++-- | The following is a similar type-only membership test+-- It uses the user-supplied curried type equality predicate pred+type family HMemberP pred e1 (l :: [*]) :: Bool+type instance HMemberP pred e1 '[] = False+type instance HMemberP pred e1 (e ': l) = HMemberP' pred e1 l (ApplyR pred (e1,e))++type family HMemberP' pred e1 (l :: [*]) pb :: Bool+type instance HMemberP' pred e1 l (Proxy True) = True+type instance HMemberP' pred e1 l (Proxy False) = HMemberP pred e1 l+++hMember :: HMember e l b => Proxy e -> Proxy l -> Proxy b+hMember _ _ = Proxy++-- ** Another type-level membership test+--+-- | Check to see if an element e occurs in a list l+-- If not, return 'Nothing+-- If the element does occur, return 'Just l1+-- where l1 is a type-level list without e+class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r+instance HMemberM e1 '[] 'Nothing+instance (HEq e1 e b, HMemberM1 b e1 (e ': l) res)+      =>  HMemberM e1 (e ': l) res++class HMemberM1 (b::Bool) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM1 True e1 (e ': l) ('Just l)+instance (HMemberM e1 l r, HMemberM2 r e1 (e ': l) res)+    => HMemberM1 False e1 (e ': l) res++class HMemberM2 (b::Maybe [k]) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM2 Nothing e1 l Nothing+instance HMemberM2 (Just l1) e1 (e ': l) (Just (e ': l1))++-- --------------------------------------------------------------------------++-- * Staged equality for lists+-- $note removed. use Typeable instead+++{-+-- * Static set property based on HEq+class HSet l+instance HSet HNil+instance (HMember e l HFalse, HSet l) => HSet (HCons e l)+-}++-- * Find an element in a set based on HEq+-- | It is a pure type-level operation+class HFind1 e l l n => HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n+instance HFind1 e l l n => HFind e l n++class HFind1 (e :: k) (l :: [k]) (l0 :: [k]) (n :: HNat) | e l -> n++instance (HEq e1 e2 b, HFind2 b e1 l l0 n) => HFind1 e1 (e2 ': l) l0 n+instance Fail (FieldNotFound e1 l0) => HFind1 e1 '[] l0 HZero++class HFind2 (b::Bool) (e :: k) (l::[k]) (l0::[k]) (n:: HNat) | b e l -> n+instance HFind2 True e l l0 HZero+instance HFind1 e l l0 n => HFind2 False e l l0 (HSucc n)++++-- ** Membership test based on type equality++-- | could be an associated type if HEq had one+class HTMember e (l :: [*]) (b :: Bool) | e l -> b+instance HTMember e '[] False+instance (HEq e e' b, HTMember e l b', HOr b b' ~ b'')+      =>  HTMember e (e' ': l) b''++hTMember :: HTMember e l b => e -> HList l -> Proxy b+hTMember _ _ = Proxy+++-- * Intersection based on HTMember++class HTIntersect l1 l2 l3 | l1 l2 -> l3+ where+  -- | Like 'Data.List.intersect'+  hTIntersect :: HList l1 -> HList l2 -> HList l3++instance HTIntersect '[] l '[]+ where+  hTIntersect _ _ = HNil++instance ( HTMember h l1 b+         , HTIntersectBool b h t l1 l2+         )+         => HTIntersect (h ': t) l1 l2+ where+  hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1+   where+    b = hTMember h l1++class HTIntersectBool (b :: Bool) h t l1 l2 | b h t l1 -> l2+ where+ hTIntersectBool :: Proxy b -> h -> HList t -> HList l1 -> HList l2++instance HTIntersect t l1 l2+      => HTIntersectBool True h t l1 (h ': l2)+ where+  hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1)++instance HTIntersect t l1 l2+      => HTIntersectBool False h t l1 l2+ where+  hTIntersectBool _ _ t l1 = hTIntersect t l1+++-- * Convert between heterogeneous lists and homogeneous ones++-- | @hMapOut id@ is similar, except this function is restricted+-- to HLists that actually contain a value (so the list produced+-- will be nonempty). This restriction allows adding a functional+-- dependency, which means that less type annotations can be necessary.+class HList2List l e | l -> e+ where+  hList2List :: HList l -> [e]+  list2HListSuffix :: [e] -> Maybe (HList l, [e])+++list2HList :: HList2List l e => [e] -> Maybe (HList l)+list2HList = fmap fst . list2HListSuffix+++instance HList2List '[e] e+ where+  hList2List (HCons e HNil) = [e]++  list2HListSuffix (e : es) = Just (HCons e HNil, es)+  list2HListSuffix [] = Nothing+++instance HList2List (e' ': l) e+      => HList2List (e ': e' ': l) e+ where+  hList2List (HCons e l) = e:hList2List l++  list2HListSuffix (e : es) = (\(hl,rest) -> (HCons e hl, rest))+                                  <$> list2HListSuffix es+  list2HListSuffix [] = Nothing++-- | @Prism [s] [t] (HList s) (HList t)@+listAsHList x = prism hList2List (\l -> case list2HListSuffix l of+                                 Just (hl,[])  -> Right hl+                                 _ -> Left []) x++-- | @Prism' [a] (HList s)@+--+-- where @s ~ HReplicateR n a@+listAsHList' x = isSimple listAsHList x+++-- --------------------------------------------------------------------------+-- * With 'HMaybe'++-- ** Turn list in a list of justs+-- | the same as @map Just@+--+-- >>> toHJust (2 .*. 'a' .*. HNil)+-- H[HJust 2,HJust 'a']+--+-- >>> toHJust2 (2 .*. 'a' .*. HNil)+-- H[HJust 2,HJust 'a']++class FromHJustR (ToHJustR l) ~ l => ToHJust l+ where+  type ToHJustR l :: [*]+  toHJust :: HList l -> HList (ToHJustR l)++instance ToHJust '[]+ where+  type ToHJustR '[] = '[]+  toHJust HNil = HNil++instance ToHJust l => ToHJust (e ': l)+ where+  type ToHJustR (e ': l) = HJust e ': ToHJustR l+  toHJust (HCons e l) = HCons (HJust e) (toHJust l)++-- | alternative implementation. The Apply instance is in "Data.HList.FakePrelude".+-- A longer type could be inferred.+toHJust2 :: (HMapCxt r (HJust ()) a b,+             ToHJust a, b ~ ToHJustR a -- added to get equivalent inference+             ) => r a -> r b+toHJust2 xs = hMap (HJust ()) xs++-- --------------------------------------------------------------------------+-- ** Extract justs from list of maybes+--+-- >>> let xs = 2 .*. 'a' .*. HNil+-- >>> fromHJust (toHJust xs) == xs+-- True++class (FromHJustR (ToHJustR l) ~ l) => FromHJust l+ where+  type FromHJustR l :: [*]+  fromHJust :: HList l -> HList (FromHJustR l)++instance FromHJust '[]+ where+  type FromHJustR '[] = '[]+  fromHJust HNil = HNil++instance FromHJust l => FromHJust (HNothing ': l)+ where+  type FromHJustR (HNothing ': l) = FromHJustR l+  fromHJust (HCons _ l) = fromHJust l++instance FromHJust l => FromHJust (HJust e ': l)+ where+  type FromHJustR (HJust e ': l) = e ': FromHJustR l+  fromHJust (HCons (HJust e) l) = HCons e (fromHJust l)++-- *** alternative implementation++-- | This implementation is shorter.+fromHJust2 :: (HMapCxt r HFromJust a b) => r a -> r b+fromHJust2 xs = hMap HFromJust xs++data HFromJust = HFromJust+instance (hJustA ~ HJust a) => ApplyAB HFromJust hJustA a where+    applyAB _ (HJust a) = a+++-- --------------------------------------------------------------------------+-- * Annotated lists++data HAddTag t = HAddTag t+data HRmTag    = HRmTag++-- hAddTag :: HMapCxt (HAddTag t) l r => t -> HList l -> HList r+hAddTag t l = hMap (HAddTag t) l++-- hRmTag ::  HMapCxt HRmTag l => HList l -> HList (HMapR HRmTag l)+hRmTag l    = hMap HRmTag l++instance (et ~ (e,t)) => ApplyAB (HAddTag t) e et+ where+  applyAB (HAddTag t) e = (e,t)+++instance (e' ~ e) => ApplyAB HRmTag (e,t) e'+ where+  applyAB _ (e,_) = e+++-- | Annotate list with a type-level Boolean+--+-- > hFlag :: HMapCxt (HAddTag (Proxy True)) l r => HList l -> HList r+hFlag l = hAddTag hTrue l+++-- --------------------------------------------------------------------------+-- * Splitting by HTrue and HFalse++-- | Analogus to Data.List.'Data.List.partition' 'snd'. See also 'HPartition'+--+-- >>> let (.=.) :: p x -> y -> Tagged x y; _ .=. y = Tagged y+-- >>> hSplit $ hTrue .=. 2 .*. hTrue .=. 3 .*. hFalse .=. 1 .*. HNil+-- (H[2,3],H[1])+--+-- it might make more sense to instead have @LVPair Bool e@+-- instead of @(e, Proxy Bool)@ since the former has the same+-- runtime representation as @e@++class HSplit l+ where+  type HSplitT l :: [*]+  type HSplitF l :: [*]+  hSplit :: HList l -> (HList (HSplitT l), HList (HSplitF l))++instance HSplit '[]+ where+  type HSplitT '[] = '[]+  type HSplitF '[] = '[]+  hSplit HNil = (HNil,HNil)++instance HSplit l => HSplit ((e, Proxy True) ': l)+ where++  type HSplitT ((e,Proxy True) ': l) = e ': HSplitT l+  type HSplitF ((e,Proxy True) ': l) = HSplitF l++  hSplit (HCons (e,_) l) = (HCons e l',l'')+   where+    (l',l'') = hSplit l++instance HSplit l => HSplit ((e,Proxy False) ': l)+ where+  type HSplitT ((e,Proxy False) ': l) = HSplitT l+  type HSplitF ((e,Proxy False) ': l) = e ': HSplitF l++  hSplit (HCons (e,_) l) = (l',HCons e l'')+   where+    (l',l'') = hSplit l+++instance HSplit l => HSplit (Tagged True e ': l)+ where++  type HSplitT (Tagged True e ': l) = e ': HSplitT l+  type HSplitF (Tagged True e ': l) = HSplitF l++  hSplit (HCons (Tagged e) l) = (HCons e l',l'')+   where+    (l',l'') = hSplit l++instance HSplit l => HSplit (Tagged False e ': l)+ where+  type HSplitT (Tagged False e ': l) = HSplitT l+  type HSplitF (Tagged False e ': l) = e ': HSplitF l++  hSplit (HCons (Tagged e) l) = (l',HCons e l'')+   where+    (l',l'') = hSplit l+{-++Let expansion makes a difference to Hugs:++HListPrelude> let x = (hFlag (HCons "1" HNil)) in hSplit x+(HCons "1" HNil,HNil)+HListPrelude> hSplit (hFlag (HCons "1" HNil))+ERROR - Unresolved overloading+*** Type       : HSplit (HCons ([Char],HTrue) HNil) a b => (a,b)+*** Expression : hSplit (hFlag (HCons "1" HNil))+++-}++-- --------------------------------------------------------------------------+-- * Splitting by Length++{- | 'splitAt'++setup++>>> let two = hSucc (hSucc hZero)+>>> let xsys = hEnd $ hBuild 1 2 3 4++If a length is explicitly provided, the resulting lists are inferred++>>> hSplitAt two xsys+(H[1,2],H[3,4])++>>> let sameLength_ :: SameLength a b => r a -> r b -> r a; sameLength_ = const+>>> let len2 x = x `sameLength_` HCons () (HCons () HNil)++If the first chunk of the list (a) has to be a certain length, the type of the+Proxy argument can be inferred.++>>> case hSplitAt Proxy xsys of (a,b) -> (len2 a, b)+(H[1,2],H[3,4])++-}+class (HLengthEq xs n,+       HAppendList1 xs ys xsys+       )+      => HSplitAt (n :: HNat) xsys xs ys+                   | n xsys -> xs ys+                      , xs ys -> xsys+                      , xs -> n+                     where+    hSplitAt :: Proxy n -> HList xsys -> (HList xs, HList ys)++instance (HSplitAt1 '[] n xsys xs ys,+          HAppendList1 xs ys xsys,+          HLengthEq xs n) =>+    HSplitAt n xsys xs ys where+      hSplitAt n xsys = hSplitAt1 HNil n xsys++-- | helper for 'HSplitAt'+class HSplitAt1 accum (n :: HNat) xsys xs ys | accum n xsys -> xs ys where+    hSplitAt1 :: HList accum -> Proxy n -> HList xsys -> (HList xs, HList ys)++instance HRevApp accum '[] xs => HSplitAt1 accum HZero ys xs ys where+    hSplitAt1 xs _zero ys = (hReverse_ xs, ys)++instance HSplitAt1 (b ': accum) n bs xs ys+    => HSplitAt1 accum (HSucc n) (b ': bs) xs ys where+    hSplitAt1 accum n (HCons b bs) = hSplitAt1 (HCons b accum) (hPred n) bs++{- | a better way to write @HLength xs ~ n@ because:++1. it works properly with ghc-7.10 (probably another example of ghc bug #10009)++2. it works backwards a bit in that if @n@ is known, then @xs@ can be+   refined:++>>> undefined :: HLengthEq xs HZero => HList xs+H[]++-}+class (SameLength' (HReplicateR n ()) xs,+        HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq (xs :: [*]) (n :: HNat) | xs -> n++instance (SameLength' (HReplicateR n ()) xs,+          HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq xs n++class HLengthEq1 (xs :: [*]) n -- pick the instance based on n's constructor+instance (HLengthEq xs n, xxs ~ (x ': xs)) => HLengthEq1 xxs (HSucc n)+instance (xxs ~ '[]) => HLengthEq1 xxs HZero++class HLengthEq2 (xs :: [*]) n | xs -> n -- pick the instance based on xs' constructor+instance (HLengthEq xs n, sn ~ HSucc n) => HLengthEq2 (x ': xs) sn+instance zero ~ HZero => HLengthEq2 '[] zero++-- | @HLengthGe xs n@ says that @HLength xs >= n@.+--+-- unlike the expression with a type family HLength,+-- ghc assumes @xs ~ (aFresh ': bFresh)@ when given a+-- constraint @HLengthGe xs (HSucc HZero)@+class HLengthGe (xs :: [*]) (n :: HNat)+instance (HLengthGe xs n, xxs ~ (x ': xs)) => HLengthGe xxs (HSucc n)+instance HLengthGe xxs HZero++-- | @HAppendList1 xs ys xsys@ is the type-level way of saying @xs ++ ys == xsys@+--+-- used by 'HSplitAt'+class HStripPrefix xs xsys ys+      => HAppendList1 (xs :: [k]) (ys :: [k]) (xsys :: [k])+        | xs ys -> xsys,+          xs xsys -> ys+          -- , ys xsys -> xs+          -- hard to prove++instance HAppendList1 '[] ys ys+instance (HAppendList1 xs ys zs) => HAppendList1 (x ': xs) ys (x ': zs)+++-- | analog of 'Data.List.stripPrefix'+class HStripPrefix xs xsys ys | xs xsys -> ys+instance (x' ~ x, HStripPrefix xs xsys ys) => HStripPrefix (x' ': xs) (x ': xsys) ys+instance HStripPrefix '[] ys ys+++-- ** take++class HTake (n :: HNat) xs ys | n xs -> ys where+    hTake :: (HLengthEq ys n, HLengthGe xs n) => Proxy n -> HList xs -> HList ys++instance HTake HZero xs '[] where+    hTake _ _ = HNil++instance (HLengthEq ys n, HLengthGe xs n, HTake n xs ys)+        => HTake (HSucc n) (x ': xs) (x ': ys) where+    hTake sn (HCons x xs) = HCons x (hTake (hPred sn) xs)++-- ** drop++class HDrop (n :: HNat) xs ys | n xs -> ys where+    hDrop :: HLengthGe xs n => Proxy n -> HList xs -> HList ys++instance HDrop HZero xs xs where+    hDrop _ xs = xs++instance (HLengthGe xs n, HDrop n xs ys) => HDrop (HSucc n) (x ': xs) ys where+    hDrop sn (HCons _ xs) = hDrop (hPred sn) xs+++-- * Conversion to and from tuples++class HTuple v t | v -> t, t -> v where+    -- | alternatively: @hUncurry (,,,)@+    hToTuple :: HList v -> t+    hFromTuple :: t -> HList v++-- | @Iso (HList v) (HList v') a b@+hTuple x = iso hToTuple hFromTuple x++-- | @Iso' (HList v) a@+hTuple' x = isSimple hTuple x++instance HTuple '[] () where+    hToTuple HNil = ()+    hFromTuple () = HNil++instance HTuple '[a,b] (a,b) where+    hToTuple (a `HCons` b `HCons` HNil) = (a,b)+    hFromTuple (a,b) = (a `HCons` b `HCons` HNil)++instance HTuple '[a,b,c] (a,b,c) where+    hToTuple (a `HCons` b `HCons` c `HCons` HNil) = (a,b,c)+    hFromTuple (a,b,c) = (a `HCons` b `HCons` c `HCons` HNil)++instance HTuple '[a,b,c,d] (a,b,c,d) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a,b,c,d)+    hFromTuple (a,b,c,d) = (a `HCons` b `HCons` c `HCons` d `HCons` HNil)++instance HTuple '[a,b,c,d,e] (a,b,c,d,e) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil) = (a,b,c,d,e)+    hFromTuple (a,b,c,d,e) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil)++instance HTuple '[a,b,c,d,e,f] (a,b,c,d,e,f) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a,b,c,d,e,f)+    hFromTuple (a,b,c,d,e,f) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil)+++-- | 'tails'+class HTails a b | a -> b, b -> a where+    hTails :: HList a -> HList b++instance HTails '[] '[HList '[]] where+    hTails _ = HCons HNil HNil++instance (HTails xs ys) => HTails (x ': xs) (HList (x ': xs) ': ys) where+    hTails xxs@(HCons _x xs) = xxs `HCons` hTails xs+++-- | 'inits'+class HInits a b | a -> b, b -> a where+    hInits :: HList a -> HList b++instance HInits1 a b => HInits a (HList '[] ': b) where+    hInits xs = HNil `HCons` hInits1 xs+++-- | behaves like @tail . inits@+class HInits1 a b | a -> b, b -> a where+    hInits1 :: HList a -> HList b++instance HInits1 '[] '[HList '[]] where+    hInits1 _ = HCons HNil HNil++instance (HInits1 xs ys,+          HMapCxt HList (FHCons2 x) ys ys',+          HMapCons x ys ~ ys',+          HMapTail ys' ~ ys)+  => HInits1 (x ': xs) (HList '[x] ':  ys') where+    hInits1 (HCons x xs) = HCons x HNil `HCons` hMap (FHCons2 x) (hInits1 xs)+++-- | similar to 'FHCons'+data FHCons2 x = FHCons2 x++instance (hxs ~ HList xs,+          hxxs ~ HList (x ': xs))+  => ApplyAB (FHCons2 x) hxs hxxs where+  applyAB (FHCons2 x) xs = HCons x xs+++-- | evidence to satisfy the fundeps in HInits+type family HMapCons (x :: *) (xxs :: [*]) :: [*]+type instance HMapCons x (HList a ': b) = HList (x ': a) ': HMapCons x b+type instance HMapCons x '[] = '[]++-- | evidence to satisfy the fundeps in HInits+type family HMapTail (xxs :: [*]) :: [*]+type instance HMapTail ( HList (a ': as) ': bs) = HList as ': HMapTail bs+type instance HMapTail '[] = '[]+++-- * partition++{- | @HPartitionEq f x1 xs xi xo@ is analogous to++> (xi,xo) = partition (f x1) xs++where @f@ is a \"function\" passed in using it's instance of 'HEqBy'+-}+class HPartitionEq f x1 xs xi xo | f x1 xs -> xi xo where+    hPartitionEq :: Proxy f -> Proxy x1 -> HList xs -> (HList xi, HList xo)++instance HPartitionEq f x1 '[] '[] '[] where+    hPartitionEq _ _ _ = (HNil, HNil)++instance+   (HEqBy f x1 x b,+    HPartitionEq1 b f x1 x xs xi xo) => HPartitionEq f x1 (x ': xs) xi xo where+      hPartitionEq f x1 (HCons x xs) = hPartitionEq1 (Proxy :: Proxy b) f x1 x xs++class HPartitionEq1 (b :: Bool) f x1 x xs xi xo | b f x1 x xs -> xi xo where+    hPartitionEq1 :: Proxy b -> Proxy f -> Proxy x1 -> x -> HList xs -> (HList xi, HList xo)++instance HPartitionEq f x1 xs xi xo =>+    HPartitionEq1 True f x1 x xs (x ': xi) xo where+      hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of+         (xi, xo) -> (x `HCons` xi, xo)++instance HPartitionEq f x1 xs xi xo =>+    HPartitionEq1 False f x1 x xs xi (x ': xo) where+      hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of+         (xi, xo) -> (xi, x `HCons` xo)+++-- * groupBy++{- | @HGroupBy f x y@ is analogous to @y = 'groupBy' f x@++given that @f@ is used by 'HEqBy'+-}+class HGroupBy (f :: t) (as :: [*]) (gs :: [*]) | f as -> gs, gs -> as where+    hGroupBy :: Proxy f -> HList as -> HList gs++instance (HSpanEqBy f a as fst snd,+          HGroupBy f snd gs) => HGroupBy f (a ': as) (HList (a ': fst) ': gs) where+    hGroupBy f (HCons x xs) = case hSpanEqBy f x xs of+                      (first, second) -> (x `HCons` first) `HCons` hGroupBy f second++instance HGroupBy f '[] '[] where+    hGroupBy _f HNil = HNil++-- * span++-- | @HSpanEq x y fst snd@ is analogous to @(fst,snd) = 'span' (== x) y@+class HSpanEqBy (f :: t) (x :: *) (y :: [*]) (fst :: [*]) (snd :: [*])+      | f x y -> fst snd, fst snd -> y where+  hSpanEqBy :: Proxy f -> x -> HList y -> (HList fst, HList snd)++instance (HSpanEqBy1 f x y fst snd,+          HAppendListR fst snd ~ y)+    => HSpanEqBy f x y fst snd where+  hSpanEqBy f x y =  hSpanEqBy1 f x y++class HSpanEqBy1 (f :: t) (x :: *) (y :: [*]) (i :: [*]) (o :: [*])+      | f x y -> i o where+  hSpanEqBy1 :: Proxy f -> x -> HList y -> (HList i, HList o)++class HSpanEqBy2 (b :: Bool) (f :: t) (x :: *) (y :: *) (ys :: [*]) (i :: [*]) (o :: [*])+      | b f x y ys -> i o where+  hSpanEqBy2 :: Proxy b -> Proxy f -> x -> y -> HList ys -> (HList i, HList o)+++instance (HEqBy f x y b,+          HSpanEqBy2 b f x y ys i o) => HSpanEqBy1 f x (y ': ys) i o where+  hSpanEqBy1 f x (HCons y ys) = hSpanEqBy2 (Proxy :: Proxy b) f x (y :: y) (ys :: HList ys)++instance HSpanEqBy1 f x '[] '[] '[] where+    hSpanEqBy1 _f _x _xs = (HNil, HNil)++instance HSpanEqBy1 f x zs i o+    => HSpanEqBy2 True f x y zs (y ': i) o where+  hSpanEqBy2 _ f x y zs = case hSpanEqBy1 f x zs of+                                      (i, o) -> (HCons y i, o)++instance HSpanEqBy2 False f x y ys '[] (y ': ys) where+  hSpanEqBy2 _b _f _x y ys = (HNil, HCons y ys)++++-- * zip++-- $note see alternative implementations in "Data.HList.HZip"++++instance (SameLengths [x,y,xy], HZipList x y xy) => HUnzip HList x y xy where+  hUnzip = hUnzipList++instance (SameLengths [x,y,xy], HZipList x y xy) => HZip HList x y xy where+  hZip = hZipList+++class HZipList x y l | x y -> l, l -> x y where+  hZipList   :: HList x -> HList y -> HList l+  hUnzipList :: HList l -> (HList x, HList y)++instance HZipList '[] '[] '[] where+  hZipList _ _ = HNil+  hUnzipList _ = (HNil, HNil)++instance ((x,y)~z, HZipList xs ys zs) => HZipList (x ': xs) (y ': ys) (z ': zs) where+  hZipList (HCons x xs) (HCons y ys) = (x,y) `HCons` hZipList xs ys+  hUnzipList (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzipList zs in (x `HCons` xs, y `HCons` ys)++-- * Monoid instance++{- | Analogous to the Monoid instance for tuples++>>> import Data.Monoid+>>> mempty :: HList '[(), All, [Int]]+H[(),All {getAll = True},[]]++>>> mappend (hBuild "a") (hBuild "b") :: HList '[String]+H["ab"]++-}+instance+   (HProxies a,+    HMapCxt HList ConstMempty (AddProxy a) a,+    HZip HList a a aa,+    HMapCxt HList UncurryMappend aa a) => Monoid (HList a) where+  mempty = hMap ConstMempty+            $ (hProxies :: HList (AddProxy a))+#if __GLASGOW_HASKELL__ <= 906+  mappend a b = hMap UncurryMappend $ hZip a b+#endif++instance+    (HZip HList a a aa,+     HMapCxt HList UncurryMappend aa a) => Semigroup (HList a) where+  a <> b = hMap UncurryMappend $ hZip a b++-- ** helper functions++data ConstMempty = ConstMempty+instance (x ~ Proxy y, Monoid y) => ApplyAB ConstMempty x y where+    applyAB _ _ = mempty++data UncurryMappend = UncurryMappend+instance (aa ~ (a,a), Monoid a) => ApplyAB UncurryMappend aa a where+    applyAB _ = uncurry mappend++data UncurrySappend = UncurrySappend+instance (aa ~ (a,a), Semigroup a) => ApplyAB UncurrySappend aa a where+    applyAB _ = uncurry (<>)
Data/HList/HListPrelude.hs view
@@ -1,687 +1,137 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  UndecidableInstances, FlexibleContexts #-}+{-# LANGUAGE CPP #-}  {- |    The HList library     (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke -   Basic declarations for typeful heterogeneous lists.--   Excuse the unstructured haddocks: while there are many declarations here-   some are alternative implementations should be grouped, and the definitions-   here are analgous to many list functions in the "Prelude".+   Declarations for various classes and functions that+   apply for the whole range of heterogeneous collections+   (HList, TIP, records, etc).  -}  module Data.HList.HListPrelude where  import Data.HList.FakePrelude -{-----------------------------------------------------------------------------} --- * Heterogeneous type sequences--data HNil      = HNil      deriving (Eq,Show,Read)-data HCons e l = HCons e l deriving (Eq,Show,Read)---{-----------------------------------------------------------------------------}---- * The set of all types of heterogeneous lists--class HList l-instance HList HNil-instance HList l => HList (HCons e l)---{-----------------------------------------------------------------------------}---- * Public constructors--hNil  :: HNil-hNil  =  HNil--hCons :: HList l => e -> l -> HCons e l-hCons e l = HCons e l---{-----------------------------------------------------------------------------}---- * Basic list functions--class HHead l h | l -> h- where-  hHead :: l -> h--instance HHead (HCons e l) e- where-  hHead (HCons e _) = e--class HTail l l' | l -> l'- where-  hTail :: l -> l'--instance HTail (HCons e l) l- where-  hTail (HCons _ l) = l----{-----------------------------------------------------------------------------}---- * A class for extension--class HExtend e l l' | e l -> l', l' -> e l- where-  hExtend :: e -> l -> l'--instance HExtend e HNil (HCons e HNil)- where-  hExtend e l = HCons e l--instance HList l => HExtend e (HCons e' l) (HCons e (HCons e' l))- where-  hExtend e l = HCons e l---{-----------------------------------------------------------------------------}---- * Appending HLists---- | The normal append for comparison--append :: [a] -> [a] -> [a]-append [] l = l-append (x:l) l' = x : append l l'----- | 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--class HReverse l1 l2 | l1 -> l2, l2 -> l1- where-  hReverse:: l1 -> l2--instance (HReverse' HNil l2 l3, HReverse' HNil l3 l2)-      =>  HReverse l2 l3- where-  hReverse l1 = hReverse' HNil l1----- l3 = (reverse l2) ++ l1--class HReverse' l1 l2 l3 | l1 l2 -> l3- where-  hReverse':: l1 -> l2 -> l3--instance HReverse' l1 HNil l1- where-  hReverse' l1 HNil = l1--instance HReverse' (HCons a l1) l2' l3-      => HReverse' l1 (HCons a l2') l3- where-  hReverse' l1 (HCons a l2') = hReverse' (HCons a l1) l2'----- ** Naive HReverse--class NaiveHReverse l l' | l -> l'- where-  naiveHReverse :: l -> l'--instance NaiveHReverse HNil HNil- where-  naiveHReverse HNil = HNil+class HExtend e l where+  type HExtendR e l+  (.*.) :: e -> l -> HExtendR e l -instance ( NaiveHReverse l l'-         , HAppend l' (HCons e HNil) l''-         )-      =>   NaiveHReverse (HCons e l) l''- where-  naiveHReverse (HCons e l)-   = hAppend (naiveHReverse l) (HCons e HNil)+infixr 2 .*.  -{-----------------------------------------------------------------------------}------- * A nicer notation for lists+-- | 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 --- | List termination-hEnd :: HCons t t1 -> HCons t t1-hEnd t@(HCons _ _) = t -{- ^-   Note:+-- | similar to 'emptyRecord', 'emptyTIP', emptyHList (actually called 'HNil'),+-- except emptyProxy is the rightmost argument to '.*.'+emptyProxy = Proxy :: Proxy ('[] :: [*]) -        [@x :: HCons a b@] means: @forall a b. x :: HCons a b@+-- Poly-kinded+class SubType l l' -        [@hEnd x@] means: @exists a b. x :: HCons a b@--}+-- subType :: SubType l l' => l -> l' -> ()+-- subType _ _ = () +class HAppend l1 l2 where+  hAppend :: l1 -> l2 -> HAppendR l1 l2 --- **  Building non-empty lists+-- | poly-kinded, but 'hAppend' only works in cases where the kind variable+-- `k` is `*`+type family HAppendR (l1::k) (l2::k) :: k+-- class HMember e1 l (b :: Bool) | e1 l -> b -hBuild   :: (HBuild' HNil a r) => a -> r-hBuild x =  hBuild' HNil x+-- One occurrence and nothing is left+class HOccurs e l where+  hOccurs :: l -> e -class HBuild' l a r | r-> a l- where-  hBuild' :: l -> a -> r+-- Class to test that a type is "free" in a type sequence+-- polykinded+class HOccursNot (e :: k) (l :: [k]) -instance HReverse (HCons a l) (HCons a' l')-      => HBuild' l a (HCons a' l')- where-  hBuild' l x = hReverse (HCons x l)+class HProject l l' where+  hProject :: l -> l' -instance HBuild' (HCons a l) b r-      => HBuild' l a (b->r)- where-  hBuild' l x y = hBuild' (HCons x l) y+-- | Map a type (key) to a natural (index) within the collection+-- This is a purely type-level computation+class HType2HNat (e :: k) (l :: [k]) (n :: HNat) | e l -> n -{- $hbuild+--  | and lift to the list of types+class HTypes2HNats es l (ns :: [HNat]) | es l -> ns -> HList> let x = hBuild True in hEnd x-> HCons True HNil+-- | Delete all elements with the type-level key e from the+-- collection l. Since the key is type-level, it is represented+-- by a Proxy.+-- (polykinded) -> HList> let x = hBuild True 'a' in hEnd x-> HCons True (HCons 'a' HNil)+class HDeleteMany e l l' | e l -> l' where+  hDeleteMany :: Proxy e -> l -> l' -> 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)))+class HDeleteAtLabel (r :: [*] -> *) (l :: k) v v' | l v -> v' where+    hDeleteAtLabel :: Label l -> r v -> r v' -> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus-> True --} -{-----------------------------------------------------------------------------} --- * A heterogeneous apply operator--class Apply f a r | f a -> r where-  apply :: f -> a -> r-  apply = undefined                     -- In case we use Apply for-                                        -- type-level computations only----- | Normal function application--instance Apply (x -> y) x y where-  apply f x = f x----- | Identity--data Id = Id--instance Apply Id x x where-  apply _ x = x---{-----------------------------------------------------------------------------}---- * A heterogeneous fold for all types--class HList l => HFoldr f v l r | f v l -> r- where-  hFoldr :: f -> v -> l -> r--instance HFoldr f v HNil v- where-  hFoldr _ v _ = v--instance ( HFoldr f v l r-         , Apply f (e,r) r'-         )-      => HFoldr f v (HCons e l) r'- where-  hFoldr f v (HCons e l) = apply f (e,hFoldr f v l)---{-----------------------------------------------------------------------------}---- * Map--class HMap f l l' | f l -> l'- where-  hMap :: f -> l -> l'--instance HMap f HNil HNil- where-  hMap _ _ = HNil--instance (-           Apply f x y,-           HMap f xs ys-         )-      => HMap f (HCons x xs) (HCons y ys)- where-  hMap f ~(HCons x xs) = HCons (apply f x) (hMap f xs)--{-----------------------------------------------------------------------------}---- * Map a heterogeneous list to a homogeneous one--class HMapOut f r e- where-  hMapOut :: f -> r -> [e]--instance HMapOut f HNil e- where-  hMapOut _ _ = []--instance ( HMapOut f l e'-         , Apply f e e'-         )-      =>   HMapOut f (HCons e l) e'- where-  hMapOut f ~(HCons e l) = apply f e : hMapOut f l---{-----------------------------------------------------------------------------}---- * A heterogenous version of mapM.------ > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b]------ Likewise for mapM_.------ See "Data.HList.HSequence" if the result list should also be heterogenous.--hMapM   :: (Monad m, HMapOut f l (m e)) => f -> 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 -> l -> m ()-hMapM_ f =  sequence_ .  disambiguate . hMapM f- where-  disambiguate :: [q ()] -> [q ()]-  disambiguate =  id---{-----------------------------------------------------------------------------}---- * A reconstruction of append--append' :: [a] -> [a] -> [a]-append' l l' = foldr (:) l' l---- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr'-hAppend' :: (HFoldr ApplyHCons v l r) => l -> v -> r-hAppend' l l' = hFoldr ApplyHCons l' l--data ApplyHCons = ApplyHCons--instance HList l => Apply ApplyHCons (e,l) (HCons e l)- where-  apply ApplyHCons (e,l) = hCons e l---{-----------------------------------------------------------------------------}---- * A heterogeneous map for all types--data HMap' f = HMap' f---- | Same as 'hMap' only a different implementation.-hMap' :: (HFoldr (HMap' f) HNil l r) => f -> l -> r-hMap' f = hFoldr (HMap' f) hNil--instance Apply f e e'-      => Apply (HMap' f) (e,l) (HCons e' l)- where-  apply (HMap' f) (e,l) = HCons e' l-   where-    e' = apply f e---{-----------------------------------------------------------------------------}---- * A function for showing--data HShow  = HShow-data HSeq x = HSeq x--instance Show x => Apply HShow x (IO ())- where-  apply _ x = do putStrLn $ show x--instance ( Monad m-         , Apply f x (m ())-         )-      => Apply (HSeq f) (x,m ()) (m ())- where-  apply (HSeq f) (x,c) = do apply f x; c---{-----------------------------------------------------------------------------}---- * Type-level equality for lists--instance HEq HNil HNil HTrue-instance HList l => HEq HNil (HCons e l) HFalse-instance HList l => HEq (HCons e l) HNil HFalse-instance (HList l, HList l', HEq e e' b, HEq l l' b', HAnd b b' b'')-      => HEq (HCons e l) (HCons e' l') b''---{-----------------------------------------------------------------------------}---- * Staged equality for lists--instance HStagedEq HNil HNil- where-  hStagedEq _ _ = True--instance HStagedEq HNil (HCons e l)- where-  hStagedEq _ _ = False--instance HStagedEq (HCons e l) HNil- where-  hStagedEq _ _ = False--instance ( TypeEq e e' b-         , HStagedEq l l'-         , HStagedEq' b e e'-         )-      =>   HStagedEq (HCons e l) (HCons e' l')- where-  hStagedEq (HCons e l) (HCons e' l') = (hStagedEq' b e e') && b'-   where-    b  = typeEq e e'-    b' = hStagedEq l l'--class HStagedEq' b e e'- where-  hStagedEq' :: b -> e -> e' -> Bool--instance HStagedEq' HFalse e e'- where-  hStagedEq' _ _ _ = False--instance Eq e => HStagedEq' HTrue e e- where-  hStagedEq' _ = (==)---{-----------------------------------------------------------------------------}----- * Ensure a list to contain HNats only--class HList l => HNats l-instance HNats HNil-instance (HNat n, HNats ns) => HNats (HCons n ns)----- * 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-class HNat n => HFind e l n | e l -> n- where-  hFind :: e -> l -> n--instance ( HEq e e' b-         , HFind' b e l n-         )-      =>   HFind e (HCons e' l) n- where-  hFind e (HCons e' l) = n-   where-    b  = hEq e e'-    n  = hFind' b e l--class HNat n => HFind' b e l n | b e l -> n- where-  hFind' :: b -> e -> l -> n--instance HFind' HTrue e l HZero- where-  hFind' _ _ _ = hZero--instance HFind e l n-      => HFind' HFalse e l (HSucc n)- where-  hFind' _ e l = hSucc (hFind e l)----- * Membership test--class HBool b => HMember e l b | e l -> b-instance HMember e HNil HFalse-instance (HEq e e' b, HMember e l b', HOr b b' b'')-      =>  HMember e (HCons e' l) b''--hMember :: HMember e l b => e -> l -> b-hMember _ _ = undefined----- ** Another type-level membership test------ Check to see if an element e occurs in a list l--- If not, return HNothing--- If the element does occur, return HJust l'--- where l' is a type-level list without e--class HMemberM e l r | e l -> r-instance HMemberM e HNil HNothing-instance (HEq e e' b, HMemberM' b e (HCons e' l) res)-      =>  HMemberM e (HCons e' l) res-class HMemberM' b e l r | b e l -> r-instance HMemberM' HTrue e (HCons e l) (HJust l)-instance (HMemberM e l r, HMemberM' r e (HCons e' l) res)-    => HMemberM' HFalse e (HCons e' l) res-instance HMemberM' HNothing e l HNothing-instance HMemberM' (HJust l') e (HCons e' l) (HJust (HCons e' l'))------ ** Membership test based on type equality--class HBool b => HTMember e l b | e l -> b-instance HTMember e HNil HFalse-instance (TypeEq e e' b, HTMember e l b', HOr b b' b'')-      =>  HTMember e (HCons e' l) b''--hTMember :: HTMember e l b => e -> l -> b-hTMember _ _ = undefined----- * Intersection based on HTMember--class HTIntersect l1 l2 l3 | l1 l2 -> l3- where-  -- | Like 'Data.List.intersect'-  hTIntersect :: l1 -> l2 -> l3--instance HTIntersect HNil l HNil- where-  hTIntersect _ _ = HNil--instance ( HTMember h l1 b-         , HTIntersectBool b h t l1 l2-         )-         => HTIntersect (HCons h t) l1 l2- where-  hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1-   where-    b = hTMember h l1--class HBool b => HTIntersectBool b h t l1 l2 | b h t l1 -> l2- where- hTIntersectBool :: b -> h -> t -> l1 -> l2--instance HTIntersect t l1 l2-      => HTIntersectBool HTrue h t l1 (HCons h l2)- where-  hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1)--instance HTIntersect t l1 l2-      => HTIntersectBool HFalse 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 :: l -> [e]--instance HList2List HNil e- where-  hList2List HNil = []--instance HList2List l e-      => HList2List (HCons e l) e- where-  hList2List (HCons e l) = e:hList2List l---{-----------------------------------------------------------------------------}---- * With 'HMaybe'---- ** Turn list in a list of justs--class ToHJust l l' | l -> l'- where-  toHJust :: l -> l'--instance ToHJust HNil HNil- where-  toHJust HNil = HNil--instance ToHJust l l' => ToHJust (HCons e l) (HCons (HJust e) l')- where-  toHJust (HCons e l) = HCons (HJust e) (toHJust l)---{-----------------------------------------------------------------------------}---- ** Extract justs from list of maybes--class FromHJust l l' | l -> l'- where-  fromHJust :: l -> l'--instance FromHJust HNil HNil- where-  fromHJust HNil = HNil--instance FromHJust l l' => FromHJust (HCons HNothing l) l'- where-  fromHJust (HCons _ l) = fromHJust l--instance FromHJust l l' => FromHJust (HCons (HJust e) l) (HCons e l')- where-  fromHJust (HCons (HJust e) l) = HCons e (fromHJust l)---{-----------------------------------------------------------------------------}---- * Annotated lists--data HAddTag t = HAddTag t-data HRmTag    = HRmTag--hAddTag :: (HMap (HAddTag t) l l') => t -> l -> l'-hAddTag t l = hMap (HAddTag t) l-hRmTag :: (HMap HRmTag l l') => l -> l'-hRmTag l    = hMap HRmTag l--instance Apply (HAddTag t) e (e,t)- where-  apply (HAddTag t) e = (e,t)+-- | '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) -instance Apply HRmTag (e,t) e- where-  apply HRmTag (e,_) = e+-- | 'zip'. Variant supports hUnzip, but not hZip ('hZipVariant' returns a Maybe)+class HUnzip r x y xy => HZip (r :: [*] -> *) x y xy where+  hZip :: r x -> r y -> r xy +#if __GLASGOW_HASKELL__ != 706+instance (lv ~ Tagged l v, HUnzip Proxy ls vs lvs)+    => HUnzip Proxy (Label l ': ls) (v ': vs) (lv ': lvs) where+    hUnzip _ = (Proxy, Proxy) --- | Annotate list with a type-level Boolean-hFlag :: (HMap (HAddTag HTrue) l l') => l -> l'-hFlag l = hAddTag hTrue l+instance HUnzip Proxy '[] '[] '[] where hUnzip _ = (Proxy, Proxy)  -{-----------------------------------------------------------------------------}---- * Splitting by HTrue and HFalse---- | Analogus to @Data.List.partition snd@--class HSplit l l' l'' | l -> l' l''- where-  hSplit :: l -> (l',l'')--instance HSplit HNil HNil HNil- where-  hSplit HNil = (HNil,HNil)--instance HSplit l l' l''-      => HSplit (HCons (e,HTrue) l) (HCons e l') l''- where-  hSplit (HCons (e,_) l) = (HCons e l',l'')-   where-    (l',l'') = hSplit l--instance HSplit l l' l''-      => HSplit (HCons (e,HFalse) l) l' (HCons e l'')- where-  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))+{- | Missing from GHC-7.6.3 due to a bug: +> let r = hEnd $ hBuild 1 2 3+> *Data.HList> hZipList r r+> H[(1,1),(2,2),(3,3)]+> *Data.HList> hZip r r+>+> <interactive>:30:1:+>     Couldn't match type `Label k l' with `Integer'+>     When using functional dependencies to combine+>       HUnzip+>         (Proxy [*]) ((':) * (Label k l) ls) ((':) * v vs) ((':) * lv lvs),+>         arising from the dependency `xy -> x y'+>         in the instance declaration at Data/HList/HListPrelude.hs:96:10+>       HUnzip+>         HList+>         ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+>         ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+>         ((':)+>            *+>            (Integer, Integer)+>            ((':) * (Integer, Integer) ((':) * (Integer, Integer) ('[] *)))),+>         arising from a use of `hZip' at <interactive>:30:1-4+>     In the expression: hZip r r+>     In an equation for `it': it = hZip r r  -}+instance HUnzip Proxy ls vs lvs+      => HZip Proxy ls vs lvs where+  hZip _ _ = Proxy+#endif  -{-----------------------------------------------------------------------------}
Data/HList/HOccurs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances,-  FlexibleContexts, OverlappingInstances, UndecidableInstances #-}  {- |    The HList library@@ -15,188 +13,141 @@  import Data.HList.FakePrelude import Data.HList.HListPrelude+import Data.HList.HList -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------+-- Given an HList l and an element type e return the suffix of l+-- whose head has the type e. Return HNil if l does not have+-- an element of type e. --- Zero or more occurrences+class HOccurrence (e1 :: *) (l :: [*]) (l' :: [*]) | e1 l -> l' where+    hOccurrence :: Proxy e1 -> HList l -> HList l' -class HOccursMany e l- where-  hOccursMany :: l -> [e]+instance HOccurrence e1 '[] '[] where+    hOccurrence _ = id -instance HOccursMany e HNil- where-  hOccursMany HNil = []+instance (HEq e1 e b, HOccurrence' b e1 (e ': l) l')+    => HOccurrence e1 (e ': l) l' where+    hOccurrence = hOccurrence' (Proxy::Proxy b) -instance ( HOccursMany e l, HList l )-      =>   HOccursMany e (HCons e l)- where-  hOccursMany (HCons e l) = e:hOccursMany l+class HOccurrence' (b :: Bool) (e1 :: *) (l :: [*]) (l' :: [*]) | b e1 l -> l' where+    hOccurrence' :: Proxy b -> Proxy e1 -> HList l -> HList l' -instance ( HOccursMany e l, HList l )-      =>   HOccursMany e (HCons e' l)- where-  hOccursMany (HCons _ l) = hOccursMany l+instance HOccurrence' True e1 (e ': l) (e ': l) where+    hOccurrence' _ _ = id +instance HOccurrence e1 l l' => HOccurrence' False e1 (e ': l) l' where+    hOccurrence' _ e (HCons _ l) = hOccurrence e l -{-----------------------------------------------------------------------------} --- One or more occurrences+-- --------------------------------------------------------------------------+-- Zero or more occurrences -class HOccursMany1 e l- where-  hOccursMany1 :: l -> (e,[e])+class HOccursMany e (l :: [*]) where+  hOccursMany :: HList l -> [e] -instance ( HOccursMany e l, HList l )-      =>   HOccursMany1 e (HCons e l)+instance (HOccurrence e l l', HOccursMany' e l')+    => HOccursMany e l  where-  hOccursMany1 (HCons e l) = (e,hOccursMany l)+  hOccursMany l = hOccursMany' (hOccurrence (Proxy::Proxy e) l) -instance ( HOccursMany1 e l, HList l )-      => HOccursMany1 e (HCons e' l)- where-  hOccursMany1 (HCons _ l) = hOccursMany1 l+class HOccursMany' e l where+  hOccursMany' :: HList l -> [e] +instance HOccursMany' e '[] where+  hOccursMany' _ = [] -{-----------------------------------------------------------------------------}+instance (e ~ e1, HOccursMany e l) => HOccursMany' e (e1 ': l) where+  hOccursMany' (HCons e l) = e : hOccursMany l --- The first occurrence -class HOccursFst e l- where-  hOccursFst :: l -> e--instance HList l-      => HOccursFst e (HCons e l)- where-  hOccursFst (HCons e _) = e+-- --------------------------------------------------------------------------+-- One or more occurrences -instance ( HOccursFst e l, HList l )-      =>   HOccursFst e (HCons e' l)- where-  hOccursFst (HCons _ l) = hOccursFst l+hOccursMany1 :: forall e l 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 (Proxy::Proxy e) l of HCons e _ -> e +-- -------------------------------------------------------------------------- -- One occurrence and nothing is left--class HOccurs e l- where-  hOccurs :: l -> e+-- This constraint is used in many places  data TypeNotFound e -instance Fail (TypeNotFound e)-      => HOccurs e HNil- where-  hOccurs = undefined--instance ( HList l-         , HOccursNot e l-         )-           => HOccurs e (HCons e l)- where-  hOccurs (HCons e _) = e--instance ( HOccurs e l-         , HList l-         )-           => HOccurs e (HCons e' l)- where-  hOccurs (HCons _ l) = hOccurs l---{-----------------------------------------------------------------------------}---- One occurrence and nothing is left--- A variation that avoids overlapping instances--class HOccurs' e l- where-  hOccurs' :: l -> e+instance (HOccurrence e (x ': y) l', HOccurs' e l' (x ': y))+    => HOccurs e (HList (x ': y)) where+    hOccurs = hOccurs' (Proxy :: Proxy (x ': y)) . hOccurrence (Proxy ::Proxy e) -instance ( TypeEq e e' b-         , HOccursBool b e (HCons e' l) )-      =>   HOccurs' e (HCons e' l)- where-  hOccurs' (HCons e' l) = e-   where-    e = hOccursBool b (HCons e' l)-    b = proxyEq (toProxy e) (toProxy e')+-- | l0 is the original list so that when we reach the end of l+-- without finding an e, we can report an error that gives an+-- idea about what the original list was.+class HOccurs' e l (l0 :: [*]) where+    hOccurs' :: Proxy l0 -> HList l -> e -class HOccursBool b e l- where-  hOccursBool :: b -> l -> e+instance Fail (FieldNotFound e (HList l0)) => HOccurs' e '[] l0 where+    hOccurs' = error "HOccurs'' Fail failed" -instance ( HList l-         , HOccursNot e l-         )-           => HOccursBool HTrue e (HCons e l)- where-  hOccursBool _ (HCons e _) = e+instance HOccursNot e l => HOccurs' e (e ': l) l0 where+    hOccurs' _ (HCons e _) = e -instance ( HOccurs' e l-         , HList l-         )-           => HOccursBool HFalse e (HCons e' l)- where-  hOccursBool _ (HCons _ l) = hOccurs' l+-- | 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 -class HOccursOpt e l- where-  hOccursOpt :: l -> Maybe e--instance HOccursOpt e HNil- where-  hOccursOpt HNil = Nothing--instance HOccursOpt e (HCons e l)- where-  hOccursOpt (HCons e _) = Just e+hOccursOpt :: forall e l l'.+              (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e+hOccursOpt = hOccursOpt' . hOccurrence (Proxy :: Proxy e) -instance HOccursOpt e l-      => HOccursOpt e (HCons e' l)- where-  hOccursOpt (HCons _ l) = hOccursOpt l+class HOccursOpt' e l where+  hOccursOpt' :: HList l -> Maybe e +instance HOccursOpt' e '[] where+  hOccursOpt' _ = Nothing -{-----------------------------------------------------------------------------}+instance e ~ e1 => HOccursOpt' e (e1 ': l) where+  hOccursOpt' (HCons e _) = Just e +-- -------------------------------------------------------------------------- -- Class to test that a type is "free" in a type sequence -data TypeFound e-class HOccursNot e l-instance HOccursNot e HNil-instance Fail (TypeFound e) => HOccursNot e (HCons e l)-instance HOccursNot e l => HOccursNot e (HCons e' l)+instance HOccursNot1 e xs xs => HOccursNot e xs +class HOccursNot1 (e :: k) (xs :: [k]) (xs0 :: [k]) -{-----------------------------------------------------------------------------}+instance HOccursNot1 (e :: k) ('[]::[k]) l0+instance (HEq e e1 b, HOccursNot2 b e l l0) => HOccursNot1 e (e1 ': l) l0+class HOccursNot2 (b :: Bool) e (l :: [k]) (l0 :: [k])+instance Fail (ExcessFieldFound e l0) => HOccursNot2 True e l l0+instance HOccursNot1 e l l0 => HOccursNot2 False e l l0 -class HProject l l'- where-  hProject :: l -> l' -instance HProject l HNil- where+-- --------------------------------------------------------------------------++instance HProject (HList l) (HList '[]) where   hProject _ = HNil -instance ( HList l'-         , HOccurs e l-         , HProject l l'-         )-      =>   HProject l (HCons e l')+instance (HOccurs e l, HProject l (HList l'))+      =>   HProject l (HList (e ': l'))  where   hProject l = HCons (hOccurs l) (hProject l)  -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------  -- * Illustration of typical test scenarios {- $example@@ -222,5 +173,3 @@ > 1  -}--{-----------------------------------------------------------------------------}
+ Data/HList/HSort.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE CPP #-}+{- | Description: sorting++Benchmarks for these functions can be found at+<http://code.haskell.org/~aavogt/HList-nodup/Run.html>.++See <Data-HList-CommonMain.html#v:hSort>+for the public interface.++-}+module Data.HList.HSort where++import Data.HList.HList+import Data.HList.FakePrelude+import Data.HList.Label3++#if __GLASGOW_HASKELL__ > 707+import GHC.TypeLits (type (<=?), CmpSymbol)+-- | only in ghc >= 7.7+instance ((x <=? y) ~ b) => HEqBy HLeFn x y b+-- | only in ghc >= 7.7++{- |++>>> let b1 = Proxy :: HEqBy HLeFn "x" "y" b => Proxy b+>>> :t b1+b1 :: Proxy 'True++>>> let b2 = Proxy :: HEqBy HLeFn "x" "x" b => Proxy b+>>> :t b2+b2 :: Proxy 'True++>>> let b3 = Proxy :: HEqBy HLeFn "y" "x" b => Proxy b+>>> :t b3+b3 :: Proxy 'False++-}+instance (HEq (CmpSymbol x y) GT nb, HNot nb ~ b) => HEqBy HLeFn x y b+#endif++-- | the \"standard\" '<=' for types. Reuses 'HEqBy'+--+-- Note that ghc-7.6 is missing instances for Symbol and Nat, so that+-- sorting only works 'HNat' (as used by "Data.HList.Label3").+data HLeFn++instance HEqByFn HLeFn++instance (HLe x y ~ b) => HEqBy HLeFn x y b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Tagged x v) (Tagged y w) b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Label x) (Label y) b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Proxy x) (Proxy y) b++-- | Data.HList.Label3 labels can only be compared if they belong+-- to the same namespace.+instance (HEqBy HLeFn n m b, ns ~ ns')+     => HEqBy HLeFn (Lbl n ns desc) (Lbl m ns' desc') b+++-- | analogous to 'Data.Ord.Down'+data HDown a+instance HEqByFn a => HEqByFn (HDown a)+instance HEqBy f y x b => HEqBy (HDown f) x y b++-- | The HEqBy instances for @HNeq HLeFn@ gives '<'+data HNeq le+instance HEqByFn a => HEqByFn (HNeq a)+instance (HEqBy le y x b1, HNot b1 ~ b2) => HEqBy (HNeq le) x y b2++{- | @HIsAscList le xs b@ is analogous to++> b = all (\(x,y) -> x `le` y) (xs `zip` tail xs)++-}+class HEqByFn le => HIsAscList le (xs :: [*]) (b :: Bool) | le xs -> b++instance HEqByFn le => HIsAscList le '[x] True+instance HEqByFn le => HIsAscList le '[] True+instance (HEqBy le x y b1,+#if __GLASGOW_HASKELL__ > 906+         HEqByFn le,+#endif+         HIsAscList le (y ': ys) b2,+         HAnd b1 b2 ~ b3)  => HIsAscList le (x ': y ': ys) b3+++-- | quick sort with a special case for sorted lists+class (SameLength a b, HEqByFn le) => HSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hSortBy :: Proxy le -> HList a -> HList b++type HSort x y = HSortBy HLeFn x y++hSort :: HSort x y => HList x -> HList y+hSort xs = hSortBy (Proxy :: Proxy HLeFn) xs++instance (SameLength a b,+          HIsAscList le a ok,+          HSortBy1 ok le a b,+          HEqByFn le) => HSortBy le a b where+    hSortBy = hSortBy1 (Proxy :: Proxy ok)++instance HSortBy1 True le a a where+    hSortBy1 _ _ a = a -- already sorted++instance HQSortBy le a b => HSortBy1 False le a b where+    hSortBy1 _ = hQSortBy++class HSortBy1 ok le (a :: [*]) (b :: [*]) | ok le a -> b where+    hSortBy1 :: Proxy ok -> Proxy le -> HList a -> HList b++-- * Merge Sort++{- | HMSortBy is roughly a transcription of this merge sort++> msort [] = []+> msort [x] = [x]+> msort [x,y] = hSort2 x y+> msort xs = case splitAt (length xs `div` 2) xs of+>              (a,b) -> msort a `merge` msort b++> hSort2 x y+>     | x <= y    = [x,y]+>     | otherwise = [y,x]++> merge (x : xs) (y : ys)+>   | x > y     = y : merge (x : xs) ys+>   | otherwise = x : merge xs (y : ys)++-}+class HEqByFn le => HMSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hMSortBy :: Proxy le -> HList a -> HList b+++instance HEqByFn le => HMSortBy le '[] '[] where hMSortBy _ x = x+instance HEqByFn le => HMSortBy le '[x] '[x] where hMSortBy _ x = x+instance (HSort2 b x y ab, HEqBy le x y b, HEqByFn le) =>+    HMSortBy le '[x,y] ab where+      hMSortBy _ (a `HCons` b `HCons` HNil) = hSort2 (Proxy :: Proxy b) a b++class HSort2 b x y ab | b x y -> ab where+    hSort2 :: Proxy b -> x -> y -> HList ab++instance HSort2 True x y '[x,y] where+    hSort2 _ x y = x `HCons` y `HCons` HNil++instance HSort2 False x y '[y,x] where+    hSort2 _ x y = y `HCons` x `HCons` HNil++instance (HMerge le xs' ys' sorted,+#if __GLASGOW_HASKELL__ > 906+          HEqByFn le,+#endif+          HMSortBy le ys ys',+          HMSortBy le xs xs',+          HLengthEq (a ': b ': c ': cs) n2,+          HDiv2 n2 ~ n,+          HSplitAt n (a ': b ': c ': cs) xs ys)+  => HMSortBy le (a ': b ': c ': cs) sorted where+  hMSortBy le abbs = case hSplitAt (Proxy :: Proxy n) abbs of+      (xs, ys) -> hMerge le (hMSortBy le xs) (hMSortBy le ys)+++class HMerge le x y xy | le x y -> xy where+    hMerge :: Proxy le -> HList x -> HList y -> HList xy++instance HMerge le '[] '[] '[] where hMerge _ _ _ = HNil+instance HMerge le (x ': xs) '[] (x ': xs) where hMerge _ x _ = x+instance HMerge le '[] (x ': xs) (x ': xs) where hMerge _ _ x = x++instance (HEqBy le x y b,+          HMerge1 b (x ': xs) (y ': ys) (l ': ls) hhs,+          HMerge le ls hhs srt)+    => HMerge le (x ': xs) (y ': ys) (l ': srt) where+  hMerge le xxs yys = case hMerge1 (Proxy :: Proxy b) xxs yys of+        (HCons l ls, hhs) -> l `HCons` hMerge le ls hhs++type HMerge1 b x y min max = (HCond b (HList x) (HList y) (HList min),+                              HCond b (HList y) (HList x) (HList max))+hMerge1 b x y = (hCond b x y, hCond b y x)++-- * Quick sort+{- | HQSortBy is this algorithm++> qsort (x : xs @ (_ : _)) = case partition (<= x) xs of+>                  (le, gt) -> qsort le ++ x : qsort gt+> qsort xs = xs++on random inputs that are not pathological (ie. not already sorted or reverse+sorted) this turns out to be faster than HMSortBy, so it is used by default.++-}+class HQSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hQSortBy :: Proxy le -> HList a -> HList b++instance HQSortBy le '[] '[] where hQSortBy _ x = x+instance HQSortBy le '[x] '[x] where hQSortBy _ x = x+instance (HPartitionEq le a (b ': bs) bGeq bLt,+        HQSortBy le bLt  sortedLt,+        HQSortBy le bGeq sortedGeq,+        HAppendListR sortedLt (a ': sortedGeq) ~ sorted,+        HAppendList sortedLt (a ': sortedGeq)) =>+    HQSortBy le (a ': b ': bs) sorted where+    hQSortBy le (a `HCons` xs) = case hPartitionEq le (Proxy :: Proxy a) xs of+                      (g,l) -> hQSortBy le l `hAppendList` (a `HCons` hQSortBy le g)+++++-- * More efficient HRLabelSet / HLabelSet+{- | Provided the labels involved have an appropriate instance of HEqByFn,+it would be possible to use the following definitions:++> type HRLabelSet = HSet+> type HLabelSet  = HSet++-}+class HEqByFn lt => HSetBy lt (ps :: [*])+instance (HEqByFn lt, HSortBy lt ps ps', HAscList lt ps') => HSetBy lt ps++class HSetBy (HNeq HLeFn) ps => HSet (ps :: [*])+instance HSetBy (HNeq HLeFn) ps => HSet ps++{- |++>>> let xx = Proxy :: HIsSet [Label "x", Label "x"] b => Proxy b+>>> :t xx+xx :: Proxy 'False++>>> let xy = Proxy :: HIsSet [Label "x", Label "y"] b => Proxy b+>>> :t xy+xy :: Proxy 'True++-}+class HIsSet (ps :: [*]) (b :: Bool) | ps -> b+instance HIsSetBy (HNeq HLeFn) ps b => HIsSet ps b++class HEqByFn lt => HIsSetBy lt (ps :: [*]) (b :: Bool) | lt ps -> b+instance (HEqByFn lt, HSortBy lt ps ps', HIsAscList lt ps' b) => HIsSetBy lt ps b+++-- | @HAscList le xs@ confirms that xs is in ascending order,+-- and reports which element is duplicated otherwise.+class HEqByFn le => HAscList le (ps :: [*])++instance (HEqByFn le, HAscList0 le ps ps) => HAscList le ps++class HEqByFn le => HAscList0 le (ps :: [*]) (ps0 :: [*])++class HEqByFn le => HAscList1 le (b :: Bool) (ps :: [*]) (ps0 :: [*])+instance ( HAscList1 le b (y ': ys) ps0, HEqBy le x y b+#if __GLASGOW_HASKELL__ > 906+         , HEqByFn le+#endif+         )+  => HAscList0 le (x ': y ': ys) ps0+instance HEqByFn le => HAscList0 le '[] ps0+instance HEqByFn le => HAscList0 le '[x] ps0++instance ( Fail '("Duplicated element", y, "using le", le, "in", ys0), HEqByFn le )+    => HAscList1 le False (y ': ys) ys0+instance HAscList0 le ys ys0 => HAscList1 le True ys ys0++{- $setup++>>> import Data.HList.TypeEqO++-}
Data/HList/HTypeIndexed.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  UndecidableInstances, FlexibleContexts #-}  {- |    The HList library@@ -13,112 +11,71 @@  import Data.HList.FakePrelude import Data.HList.HListPrelude+import Data.HList.HList import Data.HList.HArray-import Data.HList.HOccurs---{-----------------------------------------------------------------------------}--class HDeleteMany e l l' | e l -> l'- where-  hDeleteMany :: Proxy e -> l -> l'--instance HDeleteMany e HNil HNil- where-  hDeleteMany _ HNil = HNil--instance ( HList l-         , TypeEq e e' b-         , HDeleteManyCase b e e' l l'-         )-      =>   HDeleteMany e (HCons e' l) l'- where-  hDeleteMany p (HCons e' l) = l'-   where-    b  = proxyEq p (toProxy e')-    l' = hDeleteManyCase b p e' l--class HDeleteManyCase b e e' l l' | b e e' l -> l'- where-  hDeleteManyCase :: b -> Proxy e -> e' -> l -> l'--instance HDeleteMany e l l'-      => HDeleteManyCase HTrue e e l l'- where-  hDeleteManyCase _ p _ l = hDeleteMany p l---instance HDeleteMany e l l'-      => HDeleteManyCase HFalse e e' l (HCons e' l')- where-  hDeleteManyCase _ p e' l = HCons e' (hDeleteMany p l)---{-----------------------------------------------------------------------------}+import Data.HList.HOccurs () --- | Map a type to a natural+-- --------------------------------------------------------------------------+-- | Map a type to a natural (index within the collection)+-- This is a purely type-level computation -class HNat n => HType2HNat e l n | e l -> n-instance (TypeEq e' e b, HType2HNatCase b e l n)-      =>  HType2HNat e (HCons e' l) n+instance (HEq e1 e b, HType2HNatCase b e1 l n) => HType2HNat e1 (e ': l) n  -- | Helper class--class (HBool b, HNat n) => HType2HNatCase b e l n | b e l -> n-instance HOccursNot e l => HType2HNatCase HTrue e l HZero-instance HType2HNat e l n => HType2HNatCase HFalse e l (HSucc n)+class HType2HNatCase (b :: Bool) (e :: *) (l :: [*]) (n :: HNat) | b e l -> n+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 -> n-hType2HNat _ _ = undefined+hType2HNat :: HType2HNat e l n => proxy1 e -> proxy l -> Proxy n+hType2HNat _ _ = Proxy +-- | And lift to the list of types +instance HTypes2HNats ('[] :: [*]) (l :: [*]) '[] --- | Map types to naturals+instance (HType2HNat e l n, HTypes2HNats es l ns)+      => HTypes2HNats (e ': es) (l :: [*]) (n ': ns) -class HTypes2HNats ps l ns | ps l -> ns- where-  hTypes2HNats :: ps -> l -> ns+hTypes2HNats :: HTypes2HNats es l ns =>+                Proxy (es :: [*]) -> hlist l -> Proxy (ns :: [HNat])+hTypes2HNats _ _ = Proxy -instance HTypes2HNats HNil l HNil- where-  hTypes2HNats _ _ = HNil+-- --------------------------------------------------------------------------+-- Implementing the generic interfaces -instance ( HType2HNat   e l n-         , HTypes2HNats ps l ns-         )-      =>   HTypes2HNats (HCons (Proxy e) ps) l (HCons n ns)- where-  hTypes2HNats (HCons p ps) l = HCons (hType2HNat p l) (hTypes2HNats ps l)+instance HDeleteMany e (HList '[]) (HList '[]) where+  hDeleteMany _ HNil = HNil +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 (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 --- | Define type-indexed delete in terms of the natural-based primitive-hDeleteAtProxy :: (HDeleteAtHNat n l l', HType2HNat e l n) => Proxy e -> l -> l'-hDeleteAtProxy p l = hDeleteAtHNat (hType2HNat p l) l+instance HDeleteMany e (HList l) (HList l1) => HDeleteManyCase True e e l l1+ where+  hDeleteManyCase _ p _ l = hDeleteMany p l  -{-----------------------------------------------------------------------------}---- | Define type-indexed update in terms of the natural-based update-hUpdateAtType :: (HUpdateAtHNat n e l l', HType2HNat e l n) => e -> l -> l'-hUpdateAtType e l = hUpdateAtHNat (hType2HNat (toProxy e) l) e l-+instance HDeleteMany e1 (HList l) (HList l1)+      => HDeleteManyCase False e1 e l (e ': l1) where+  hDeleteManyCase _ p e l = HCons e (hDeleteMany p l) -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------+-- Type-indexed operations in terms of the natural-based primitives --- | Projection based on proxies-hProjectByProxies :: (HProjectByHNats ns l l', HTypes2HNats ps l ns) => ps -> l -> l'-hProjectByProxies ps l = hProjectByHNats (hTypes2HNats ps l) l+hDeleteAt p l = hDeleteAtHNat (hType2HNat p l) l +hUpdateAt e l = hUpdateAtHNat (hType2HNat (Just e) l) e l -{-----------------------------------------------------------------------------}+hProjectBy ps l = hProjectByHNats (hTypes2HNats ps l) l --- | Splitting based on proxies-hSplitByProxies :: (HMap (HAddTag HTrue) l l', HSplitByHNats' ns l' l'1 l'',-                   HTypes2HNats ps l ns) =>-                  ps -> l -> (l'1, l'')-hSplitByProxies ps l = hSplitByHNats (hTypes2HNats ps l) 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
@@ -1,4 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}  {- |    The HList library@@ -6,78 +5,105 @@    (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke     Zipping and unzipping for (conceptually) lists of pairs.++   Provides two alternative implementations  -}  module Data.HList.HZip where -import Data.HList.HListPrelude+import Data.HList.HList+import Data.HList.FakePrelude +-- * zip+-- ** functional dependency -{-----------------------------------------------------------------------------}+-- $note1 moved to "Data.HList.HList" to avoid an orphan instance --- | Zip and unzip+-- ** type family+-- $note 'hZip2' can be written as a standalone function, with an appropriate+-- type family to calculate the result type. However, that does not seem to+-- be the case for 'hUnzip2', so to re-use some type functions the two are+-- in the same class. -class HZip x y l | x y -> l, l -> x y- where-  hZip   :: x -> y -> l-  hUnzip :: l -> (x,y)+-- | HZipR in the superclass constraint doesn't hurt, but it doesn't seem to be+-- necessary+class HZipR (MapFst z) (MapSnd z) ~ z => HUnZip z where+  type MapFst z :: [*]+  type MapSnd z :: [*]+  hZip2 :: HList (MapFst z) -> HList (MapSnd z) -> HList z+  hUnzip2 :: HList z -> (HList (MapFst z), HList (MapSnd z)) -{-+instance HUnZip '[] where+  type MapFst '[] = '[]+  type MapSnd '[] = '[]+  hZip2 _ _ = HNil+  hUnzip2 _ = (HNil, HNil) --- Zipping version I+instance (z ~ (x,y), HUnZip zs) => HUnZip (z ': zs) where+  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)+  hUnzip2 (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip2 zs in (x `HCons` xs, y `HCons` ys) --- | Test for zippability: equal length. -class HZippable x y-instance HZippable HNil HNil-instance HZippable l l' => HZippable (HCons e l) (HCons e' l')+-- | calculates something like:+--+-- > [a] -> [b] -> [(a,b)]+--+-- can be used to give another type for 'hZip2'+--+-- > hZip2 :: HList a -> HList b -> HList (HZipR a b)+type family HZipR (x::[*]) (y::[*]) :: [*]+type instance HZipR '[] '[] = '[]+type instance HZipR (x ': xs) (y ': ys) = (x,y) ': HZipR xs ys --- Somehow too polymorphic.--- Version II specialises for HNil and HCons. -instance HZippable x y => HZip x y (x,y)- where-  hZip x y = (x,y)-  hUnzip = id+-- ** utility type functions+-- $note do they belong somewhere else?+type family Fst a+type instance Fst (a,b) = a+type family Snd a+type instance Snd (a,b) = b --} -{-+-- * transpose --- Zipping version II--- Built-in show and alias-based type construction inconvenient.--- Version III goes for a true list of pairs.+{- | this transpose requires equal-length HLists inside a HList: -instance HZip HNil HNil (HNil,HNil)- where-  hZip x y = (x,y)-  hUnzip = id+>>> import Data.HList.HListPrelude+>>> let ex = (1 .*. 2 .*. HNil) .*. ('a' .*. 'b' .*. HNil) .*. ( 3 .*. 5 .*. HNil) .*. HNil -instance HZip xt yt zt-      => HZip (HCons xh xt) (HCons yh yt) (HCons xh xt,HCons yh yt)- where-  hZip x y = (x,y)-  hUnzip = id+The original list: +>>> ex+H[H[1,2],H['a','b'],H[3,5]]++And transposed:++>>> hTranspose ex+H[H[1,'a',3],H[2,'b',5]]+ -}+hTranspose x = hFoldr HZipF (hReplicate (hLength (hHead x)) HNil) x  --- {-+-- ** helpers ---- Zipping version III---- Works best for us.+-- | same as 'HZip' but HCons the elements of x onto y. This might be doable as+-- a @hMap f (hZip x y)@, but that one doesn't propagate types as easily it+-- seems.+class HZip3 x y l | x y -> l, l -> x y where+  hZip3   :: HList x -> HList y -> HList l -instance HZip HNil HNil HNil- where-  hZip HNil HNil = HNil-  hUnzip HNil = (HNil,HNil)+instance HZip3 '[] '[] '[] where+  hZip3 _ _ = HNil -instance HZip tx ty l-      => HZip (HCons hx tx) (HCons hy ty) (HCons (hx,hy) l)- where-  hZip (HCons hx tx) (HCons hy ty) = HCons (hx,hy) (hZip tx ty)-  hUnzip (HCons (hx,hy) l) = (HCons hx tx, HCons hy ty)-   where-    (tx,ty) = hUnzip l+instance (HList (x ': y) ~ z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where+  hZip3 (HCons x xs) (HCons y ys) = HCons x y  `HCons` hZip3 xs ys --- -}+data HZipF = HZipF+instance (+    HZip3 a b c,+    x ~ (HList a, HList b),+    y ~ HList c) => ApplyAB HZipF x y+    where applyAB _ (x,y) = hZip3 x y
+ Data/HList/Keyword.hs view
@@ -0,0 +1,673 @@++{- | Description: keyword arguments++The public interface is exposed in <Data-HList-CommonMain.html#t:Kw CommonMain#Kw>++-}+module Data.HList.Keyword (++  -- * main+  Kw(..),+  IsKeyFN,++  recToKW,++  -- ** another label type+  K(..),++  -- * types for user error+  ErrReqdArgNotFound,+  ErrUnexpectedKW,+++  -- * demo+  -- ** setup data types+  -- $setup+  -- $ex2++  -- * Implementation details+  -- $imploutline+  KWApply(..),+  KWApply'(..),+  Arg(..),++++  -- ** producing lists from a function's arguments+  reflect_fk,+  ReflectFK,+  ReflectFK',+++  -- ** collecting arguments+  KW(..),+  KW'(..),+  KWAcc(..),++  -- ** merging default with supplied arguments+  KWMerge(..),+  KWMerge'(..),+  KWMerge''(..),++  HDelete, HDelete',+++  -- * original introduction+  -- $originalIntro+++  -- * todo+  -- $todo++  -- * internal for type signature prettiness+  TaggedToKW,+  ) where++import GHC.TypeLits+import Data.HList.FakePrelude+import Data.HList.TypeEqO+import Data.HList.HListPrelude+import Data.HList.HList+import Data.HList.Record++{- $setup++ >>> :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+labels and useful datatypes++ >>> data Color = Color+ >>> data Size  = Size+ >>> data Origin  = Origin+ >>> data RaisedBorder = RaisedBorder+++The number of arguments each keyword must be specified by an 'IsKeyFN'+instance.++ >>> instance IsKeyFN (Color->a->b)  True+ >>> instance IsKeyFN (Size->a->b)   True+ >>> instance (a ~ (Int,Int)) => IsKeyFN (Origin->a->b) True+ >>> instance IsKeyFN (RaisedBorder->a->b) True++Note that if a keyword is always followed by a certain type, that+can be specified above using an instance like the one for Origin.++ >>> data CommonColor = Red | Green | Blue deriving Show+ >>> data RGBColor = RGBColor Int Int Int deriving Show++and two functions:++ >>> :{+ let make_square Size n Origin (x0,y0) Color (color::CommonColor) =+        unwords ["Square:", show (n :: Int), "at", show (x0,y0), show color] ++ "\n"+ :}++ >>> :{+ let make_rect Size (nx,ny) Origin (x0,y0) Color (color::RGBColor)+         RaisedBorder border =+        unwords ["Rectangle:", show (nx,ny), "at", show (x0,y0),+             show color, if border then "raised border" else ""] ++ "\n"+ :}++-}++{- $ex2++We are not interested in really drawing squares and rectangles+here. Therefore, make_square and make_rect return a String, which we+can regard as a ``command'' to be passed to a low-level graphics+library. The functions make_square and make_rect are genuine functions+and can be used as such. They are not keyword argument functions, yet,+but they set the stage. These functions can be considered an+`interface' for the keyword argument functions. We should note that+the functions are polymorphic: for example, `Size' can be any+showable. We must also emphasize the re-use of the labels: The Color+of a square is the value of the enumerated type CommonColor. OTH, the+color of the rectangle is given as an RGB triple. The sizes of the+square and of the rectangle are specified differently too, the same+label notwithstanding.++Once the user wrote the functions such as make_square and make_rect,+he can _automatically_ convert them to their keyword+alternatives. This transformation is done by a function 'kw'. The user+should pass the positional-argument function (`labeled' as above),+and an HList of default values for some of the labels. The latter may+be HNil if all keyword arguments are required.++The first example (no defaults)++ >>> kw (make_square .*. HNil) Size (1::Int) Origin (0,10) Color Red   :: String+ "Square: 1 at (0,10) Red\n"++we can permute the arguments at wish++ >>> kw (make_square .*. HNil) Color Red Size (1::Int) Origin (0,10)   :: String+ "Square: 1 at (0,10) Red\n"++we can also assign a name to a keyword function, or partially apply it:++ >>> :{+ case kw (make_square .*. HNil) Color Red of+    f -> "here: " ++ f Origin (0,10) Size (1::Int)+:}+"here: Square: 1 at (0,10) Red\n"++Note that it is necessary to use a monomorphic pattern binding here (lambda or+case). One way to get around this is to pass @f@ instead of @kw f@ around:++>>> :{+ let f = hEnd $ hBuild make_square Color Red+ in "here: " ++ kw f Origin (0,10) Size (1::Int)+:}+"here: Square: 1 at (0,10) Red\n"++The following is a more interesting example, with the+defaults:++ >>> :{+let addDef f = f .*. Origin .*. (0,10) .*.+             RaisedBorder .*. True .*.+             HNil+    in kw (addDef make_square) Size (1::Int) Color Red +++       kw (addDef make_rect)   Color (RGBColor 0 10 255)+                               Size (1.0::Float, 2.0::Float)+:}+"Square: 1 at (0,10) Red\nRectangle: (1.0,2.0) at (0,10) RGBColor 0 10 255 raised border\n"++The argument RaisedBorder is not given, and so the default value is+used. Of course, we can override the default:++ >>> :{+let addDef f =  f .*. Origin .*. (0,10) .*.+                    RaisedBorder .*. True .*.+                    HNil+ in case kw (addDef make_square) Color of+     sq -> case kw (addDef make_rect)  of+      re ->+         sq Red Size (1::Int) +++         re Color (RGBColor 0 10 255)+             RaisedBorder False+             Size (1.0::Float, 2.0::Float)+:}+"Square: 1 at (0,10) Red\nRectangle: (1.0,2.0) at (0,10) RGBColor 0 10 255 \n"++We have reshuffled a few arguments, just for fun. As you can see, the+function `kw make_rect defaults' is polyvariadic indeed.  We chose to+partially apply 'Color' to the function `kw make_square defaults' --+so that the function `sq' is positional in its first argument, and+keyword in the rest.++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)+>+>   Couldn't match `ErrReqdArgNotFound Size' against `[Char]'+>       Expected type: ErrReqdArgNotFound Size+>       Inferred type: [Char] ...++The error message seems reasonably clear. Likewise we get an error+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+>+>   No instances for (Fail (ErrUnexpectedKW RaisedBorder),+>             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'+++The function 'kw' receives the appropriately labeled function (such+as make_square) and the HList with default values. The function 'kw'+is polymorphic; the overloading is resolved based on the type of the+user function *and* on the type of its continuation. The continuation+indicates if a keyword argument is forthcoming, or not. In the latter+case, 'kw' checks to see if the supplied defaults can provide the+values of the still missing arguments. We see therefore that a+function type is more than it may appear -- the type of a function is+truly a heterogeneous, type level collection! The function 'kw'+traverses that collection, thus performing a limited form of+reflection on Haskell functions.++-}+++{- $imploutline++One of the key tools of the implementation is 'kwapply', which applies+a function to a polymorphic collection of that function's arguments.+The order of the arguments in the collection is irrelevant. The+contraption kwapply can handle polymorphic functions with arbitrary+number of labeled arguments.++For example, if we define++> f1 Size n = show n+> f2 Size n Color m = unwords ["size:", show n, "color:", show m]+> f3 Origin x Color m Size n =+>     unwords ["origin:", show x, "size:", show n, "color:",show m]++then we can run++> katest1  = kwapply f1 (Size .*. () .*. HNil)+> katest11 = kwapply f1 (Size .*. "Large" .*. HNil)+>+> katest2  = kwapply f2 (Size .*. (1::Int) .*. Color .*. Red .*. HNil)+> katest21 = kwapply f2 (Color .*. Red .*. Size .*. (1::Int) .*.  HNil)+>+> katest3  = kwapply f3 (Size .*. (1::Int) .*. Origin .*. (2.0::Float) .*.+>                  Color .*. Red .*. HNil)++-}+++-- | Another key contraption is++reflect_fk:: (ReflectFK fn kws) => fn -> Arg kws '[]+reflect_fk _ = Arg HNil++{- ^++that reflects on a user-supplied function. It converts the *type* of a+user function to a collection of keywords required by that+function. This and the previous contraptions may be used to define an+`extended' version of some user function that takes more arguments --+without the need to enumerate all arguments of the original+function. We thus infringe on the area of object and module systems.++The rest of the implementation is just to convert `kw fn defaults'+into the application of kwapply.++-}+++-- * The rest of the implementation+{- $impl++We should note that all implementation is written in the+continuation-passing style (CPS) -- at the term level and especially+at the _typeclass level_. One of the reasons is to avoid relying on+overlapping instances: we compare types with a predicate `TypeEq x y+hbool', obtain the type-level boolean, and dispatch to two+non-overlapping instances of an auxiliary, continuation class. One+instance handles HTrue, and the other the HFalse alternative. Please+see the HList paper for more discussion of this technique.++The other, equally important reason for the thorough CPS of the+typeclasses is to control the order of evaluation of constraints and+their functional dependencies. The sole reason is to produce+informative error messages. The order of constraints is irrelevant+when all the constraints are satisfied. However, if the user omitted a+required keyword, many of the constraints below will fail. If a+'wrong' constraint fails first, we get a totally off-the-wall error+message that gives us no clue whatsoever about the problem. By tightly+constraining the order via CPS, we are able to force the typechecker+to give informative error messages.++-}++++-- * Errors++data ErrReqdArgNotFound x+data ErrUnexpectedKW x+++instance IsKeyFN (Label (s :: Symbol) -> a -> b) True+{- ^ labels that impose no restriction on the type of the (single) argument+ which follows++ >>> let testF (_ :: Label "a") (a :: Int) () = a+1+ >>> kw (hBuild testF) (Label :: Label "a") 5 ()+ 6++-}++{- | The purpose of this instance is to be able to use the same Symbol+ (type-level string) at different types. If they are supposed to be the same,+ then use 'Label' instead of 'K'++ >>> let kA = K :: forall t. K "a" t+ >>> let testF (K :: K "a" Int) a1 (K :: K "a" Integer) a2 () = a1-fromIntegral a2++ therefore the following options works:++ >>> kw (hBuild testF) kA (5 :: Int) kA (3 :: Integer) ()+ 2++ >>> kw (hBuild testF) (K :: K "a" Integer) 3 (K :: K "a" Int) 5 ()+ 2++ But you cannot leave off all @Int@ or @Integer@ annotations.++-}+instance (r ~ (c -> b)) => IsKeyFN ( (K s c) -> r) True++data K s (c :: *) = K+++-- * The implementation of KWApply++class KWApply f arg_values r where+    kwapply:: f -> HList arg_values -> r++instance (r ~ r') => KWApply r '[] r' where+    kwapply f _ = f++instance (HEq kw kw' flag,+      KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r)+    => KWApply (kw ->a->f') (kw' ': a' ': tail) r where+    kwapply = kwapply' (Proxy :: Proxy flag)++class KWApply' flag f arg_values r  where+    kwapply':: Proxy flag -> f -> HList arg_values -> r++instance  (v' ~ v, KWApply f' tail r)+    => KWApply' True (kw->v->f') (kw ': v' ': tail) r where+    kwapply' _ f (HCons kw_ (HCons v' tl)) =+                   kwapply (f kw_ v') tl++-- | Rotate the arg list ...+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))++{- |++The datatype Arg below is to maintain the state of keyword+accumulation: which keywords we need, and which keyword and values we+have already got.+arg_types is the phantom HList of keywords that are yet to be satisfied.+arg_values is the @HList (kw .*. kw_value .*. etc)@+of already found keywords and their values.+-}++newtype Arg arg_types arg_values = Arg (HList arg_values)+deriving instance Show (HList vals) => Show (Arg tys vals)++{- | Reflection on a function:+Given a function, return the type list of its keywords++>>> :t reflect_fk (undefined::Size->Int->Color->CommonColor->String)+reflect_fk (undefined::Size->Int->Color->CommonColor->String)+  :: Arg '[Size, Color] '[]++>>> :t reflect_fk (undefined::Size->Int->()->Int)+reflect_fk (undefined::Size->Int->()->Int) :: Arg '[Size] '[]+++-}++class ReflectFK f (kws :: [*])+instance (IsKeyFN f flag, ReflectFK' flag f kws) => ReflectFK f kws+class ReflectFK' (flag :: Bool) f kws+instance (kkws ~ (kw ': kws), ReflectFK rest kws) => ReflectFK' True (kw->a->rest) kkws+instance ('[] ~ nil) => ReflectFK' False f nil+++-- | The main class: collect and apply the keyword arguments++class KW f arg_desc arg_def r where+    kwdo :: f -> arg_desc -> HList arg_def -> r++instance (IsKeyFN r rflag,+        KW' rflag f arg_desc arg_def r)+    => KW f arg_desc arg_def r where+    kwdo = kw' (Proxy ::Proxy rflag)++class KW' rflag f arg_desc arg_def r where+    kw' :: Proxy rflag -> f -> arg_desc -> HList arg_def -> r++{- |+If the continuation r does not promise any more keyword+arguments, apply the defaults -}++instance KWMerge arg_needed arg_values arg_def f r+    => KW' False f (Arg arg_needed arg_values) arg_def r where+    kw' _ f args_given arg_def = kwmerge args_given arg_def f++{- | Otherwise, collect the supplied keyword and its value, and recurse for+more: -}++instance (KWAcc arg_desc kw a f arg_def r, (kw->a->r) ~ kwar)+    => KW' True f arg_desc arg_def kwar where+    kw' _ f arg_desc arg_def kw_ a = kwaccum arg_desc kw_ a f arg_def+++{- | Add the needed arguments from arg_def to arg_values and continue+with kwapply.++That is, we try to satisfy the missing arguments from the defaults.+It will be a type error if some required arguments are missing -}++class KWMerge arg_needed arg_values arg_def f r where+    kwmerge:: Arg arg_needed arg_values -> HList arg_def -> f -> r++instance KWApply f arg_values r+    => KWMerge '[] arg_values arg_def f r where+    kwmerge (Arg arg_values) _ f = kwapply f arg_values++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++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++instance (Fail (ErrReqdArgNotFound kw), nff ~ (ErrReqdArgNotFound kw))+    => KWMerge' kw '[] atail arg_values arg_def f+                nff where+    kwmerge' = undefined+instance (HEq kw kw' flag,+      KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r)+    => KWMerge' kw (kw' ': etc) atail arg_values arg_def f r where+    kwmerge' = kwmerge'' (Proxy :: Proxy flag)++class KWMerge'' (flag :: Bool) kw (list :: [*]) atail arg_values arg_def f r+     where+    kwmerge'':: Proxy flag -> kw -> HList list+        -> Arg atail arg_values -> HList arg_def+        -> 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)))+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++-- | Add the real argument to the Arg structure, and continue++class KWAcc arg_desc kw a f arg_def r where+    kwaccum:: arg_desc -> kw -> a -> f -> HList arg_def -> r+++instance (HDelete kw arg_types arg_types',+      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))+++-- | Delete e from l to yield l' The element e must occur in l++class HDelete e (l :: [k]) (l' :: [k])+instance (Fail (ErrUnexpectedKW e), r ~ '[]) => HDelete e '[] r+instance (HEq e e' flag, HDelete' flag e (e' ': tail) l')+    => HDelete e (e' ': tail) l'+class HDelete' (flag :: Bool) e l l'+instance (tail' ~ tail) => HDelete' True e (e ': tail) tail'+instance (HDelete e tail tail', e'tail ~ (e' ': tail'))+    => HDelete' False e (e' ': tail) e'tail+++{- |++@kw@ takes a 'HList' whose first element is a function, and the rest+of the elements are default values.+A useful trick is to have a final argument @()@ which is not+eaten up by a label (A only takes 1 argument). That way when you supply+the () it knows there are no more arguments (?).++>>> data A = A+>>> instance IsKeyFN (A -> a -> b) True+>>> let f A a () = a + 1+>>> let f' = f .*. A .*. 1 .*. HNil++>>> kw f' A 0 ()+1++>>> kw f' ()+2++-}+class Kw (fn :: *) (arg_def :: [*]) r where+    kw :: HList (fn ': arg_def) -> r++instance+    (KW' rflag fn akws arg_def r,+     akws ~ (Arg (kws :: [*]) '[]),+     ReflectFK' flag fn kws, IsKeyFN r rflag,+     IsKeyFN fn (flag::Bool)) => Kw fn arg_def r+   where+    kw (HCons f arg_def) = kwdo f rfk arg_def :: r+        where rfk = reflect_fk f :: akws++data TaggedToKW = TaggedToKW+instance (x ~ Tagged l v, y ~ HList '[Label l, v]) =>+        ApplyAB TaggedToKW x y where+    applyAB _ (Tagged v) = hBuild Label v+++{- | convert a 'Record' into a list that can supply+default arguments for 'kw'++A bit of setup:++>>> :set -XQuasiQuotes+>>> import Data.HList.RecordPuns+>>> let f (_ :: Label "a") a (_ :: Label "b") b () = a `div` b+++>>> let a = 2; b = 1; f' = f .*. recToKW [pun| a b |]+>>> kw f' ()+2++>>> kw f' (Label :: Label "a") 10 ()+10+++-}+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)++{- $originalIntro++> From oleg-at-okmij.org Fri Aug 13 14:58:35 2004+> To: haskell@haskell.org+> Subject: Keyword arguments+> From: oleg-at-pobox.com+> Message-ID: <20040813215834.F1FF3AB7E@Adric.metnet.navy.mil>+> Date: Fri, 13 Aug 2004 14:58:34 -0700 (PDT)+> Status: OR+++We show the Haskell implementation of keyword arguments, which goes+well beyond records (e.g., in permitting the re-use of+labels). Keyword arguments indeed look just like regular, positional+arguments. However, keyword arguments may appear in any+order. Furthermore, one may associate defaults with some keywords; the+corresponding arguments may then be omitted. It is a type error to+omit a required keyword argument. The latter property is in stark+contrast with the conventional way of emulating keyword arguments via+records. Also in marked contrast with records, keyword labels may be+reused throughout the code with no restriction; the same label may be+associated with arguments of different types in different+functions. Labels of Haskell records may not be re-used.  Our solution+is essentially equivalent to keyword arguments of DSSSL Scheme or+labels of OCaml.++Keyword argument functions are naturally polyvariadic: Haskell does+support varargs! Keyword argument functions may be polymorphic. As+usual, functions with keyword arguments may be partially applied. On+the downside, sometimes one has to specify the type of the return+value of the function (if the keyword argument function has no+signature -- the latter is the norm, see below) -- provided that the+compiler cannot figure the return type out on its own. This is usually+only the case when we use keyword functions at the top level (GHCi+prompt).++Our solution requires no special extensions to Haskell and works with+the existing Haskell compilers; it is tested on GHC 6.0.1. The+overlapping instances extension is not necessary (albeit it is+convenient).++The gist of our implementation is the realization that the type of a+function is a polymorphic collection of its argument types -- a+collection that we can traverse. This message thus illustrates a+limited form of the reflection on a function.+++Our implementation is a trivial extension of the strongly-typed+polymorphic open records described in+    <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+from the above site.++The HList paper discusses the issue of labels in some detail. The+paper gives three different representations. One of them needs no+overlapping instances and is very portable. In this message, we chose+a representation that relies on generic type equality and therefore+needs overlapping instances as implemented in GHC. Again, this is+merely an outcome of our non-deterministic choice. It should be+emphasized that other choices are possible, which do not depend on+overlapping instances at all. Please see the HList paper for details.++-}+++{- $todo++[@better instances for Symbol@]++There isn't a pair @(K2 \"Origin\" (Int, Int))@ @(K \"hi\")@ that behaves just like Origin below.+something is possible between constraintkinds. See 'Data.HList.FakePrelude.Fun'++> instance (a ~ (Int,Int)) => IsKeyFN (Origin->a->b) True++[@wildcard/catchall@]++like in R. This would be a special keyword for keyword args that didn't match.+They would be put in a HList/Record argument like @...@++[@investigate first-classness of varargs@]+for whatever reason you can't have  @f = kw fn blah@ and then pass more arguments+on to fn. This is bad. It used to work (in the ghc6.0 days and probably up to+6.12). Some convenience functions/operators should be added which do the same+thing as:++> fn `hAppendList` hBuild a b c d e+++-}
− Data/HList/Label1.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}--{- |-   The HList library--   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   A model of label as needed for extensible records.--   Record labels are simply type-level naturals.-   This models is as simple and as portable as it could be.--}--module Data.HList.Label1 where--import Data.HList.FakePrelude-import Data.HList.Record (ShowLabel(..))----- | Labels are type-level naturals--newtype Label x = Label x deriving Show----- | Public constructors for labels--label :: HNat n => n -> Label n-label =  Label----- | Construct the first label-firstLabel :: Label HZero-firstLabel = label hZero----- | Construct the next label-nextLabel ::( HNat t) => Label t -> Label (HSucc t)-nextLabel (Label n) = label (hSucc n)----- | Equality on labels--instance HEq n n' b-      => HEq (Label n) (Label n') b----- | Show label--instance Show n => ShowLabel (Label n)- where-  showLabel (Label n) = show n
− Data/HList/Label2.hs 
@@ -1,70 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, EmptyDataDecls #-}--{- |-   The HList library--   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   A model of labels as needed for extensible records. As before,-   all the information about labels is recorded in their type, so-   the labels of records may be purely phantom. In general,-   Labels are exclusively type-level entities and have no run-time-   representation.--   Record labels are triplets of type-level naturals, namespace,-   and description. The namespace part helps avoid confusions between-   labels from different Haskell modules. The description is-   an arbitrary nullary type constructor.--   For the sake of printing, the namespace part and the description-   are required to be the instance of Show. One must make sure that-   the show functions does not examine the value, as descr is purely phantom.-   Here's an example of the good Label description:--   >     data MyLabelDescr; instance Show MyLabelDescr where show _ = "descr"--   which obviously can be automated with Template Haskell.--   This model requires all labels in a record to inhabit the same namespace.--}--module Data.HList.Label2 where--import Data.HList.FakePrelude-import Data.HList.Record (ShowLabel(..))----- | Labels are type-level naturals--data Label x ns desc  -- labels are exclusively type-level entities----- | Construct the first label--firstLabel :: ns -> desc -> Label HZero ns desc-firstLabel = undefined----- | Construct the next label-nextLabel :: Label x ns desc -> desc' -> Label (HSucc x) ns desc'-nextLabel = undefined----- | Equality on labels (descriptions are ignored)--instance HEq x x' b-      => HEq (Label x ns desc1) (Label x' ns desc2) b----- | Show label--instance (HNat x, Show desc) => ShowLabel (Label x ns desc) where-  showLabel = show . getd-      where getd :: Label x ns desc -> desc-            getd = undefined--instance (HNat x, HNat2Integral x,Show ns) => Show (Label x ns desc) where-  show l = unwords ["L",show ((hNat2Integral x)::Integer), show ns]-      where geti :: Label x ns desc -> (x,ns) -- for the sake of Hugs-            geti = undefined-            (x,ns) = geti l
Data/HList/Label3.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, EmptyDataDecls #-}+{-# LANGUAGE CPP #-}  {- |++   Description : namespaced labels+    The HList library     (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke@@ -23,7 +26,7 @@     >     data MyLabelDescr; instance Show MyLabelDescr where show _ = "descr" -   which obviously can be automated with Template Haskell.+   which are automated by makeLabels3 from "Data.HList.MakeLabel".     This model even allows the labels in a record to belong to different    namespaces. To this end, the model employs the predicate for type@@ -33,44 +36,132 @@ module Data.HList.Label3 where  import Data.HList.FakePrelude-import Data.HList.Record (ShowLabel(..))+import Data.HList.HListPrelude+import GHC.TypeLits+import Data.Typeable +{- $setup --- | Labels are type-level naturals-data Label x 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 HZero ns desc-firstLabel = undefined+firstLabel :: ns -> desc -> Label (Lbl HZero ns desc)+firstLabel _ _ = Label   -- | Construct the next label-nextLabel :: Label x ns desc -> desc' -> Label (HSucc x) ns desc'-nextLabel = undefined+nextLabel :: Label (Lbl x ns desc) -> desc' -> Label (Lbl (HSucc x) ns desc')+nextLabel _ _ = Label   -- | Equality on labels (descriptions are ignored)-+-- Use generic instance+{- instance ( HEq x x' b-         , TypeEq ns ns' b'-         , HAnd b b' b''+         , HEq ns ns' b'+         , bres ~ HAnd b b'          )-      =>   HEq (Label x ns desc) (Label x' ns' desc') b''-+      =>   HEq (Lbl x ns desc) (Lbl x' ns' desc') bres+-}  -- | Show label -instance (HNat x, Show desc) => ShowLabel (Label x ns desc) where+instance Show desc => ShowLabel (Lbl x ns desc) where   showLabel = show . getd-      where getd :: Label x ns desc -> desc -- for the sake of Hugs-            getd = undefined+      where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs+            getd = error "Data.HList.Label3 desc" -instance (HNat x, Show desc) => Show (Label x ns desc)+instance Show desc => Show (Label (Lbl x ns desc))  where   show = show . getd-      where getd :: Label x ns desc -> desc -- for the sake of Hugs-            getd = undefined+      where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs+            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/Label4.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, EmptyDataDecls #-}-{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Yet another model of labels.--   Labels are type proxies.--   See "Data.HList.MakeLabels"--}--module Data.HList.Label4 where--import Data.Typeable-import Data.Char--import Data.HList.FakePrelude-import Data.HList.Record----- | Equality on labels--instance TypeEq x y b => HEq (Proxy x) (Proxy y) b----- | Show label--instance Typeable x => ShowLabel (Proxy x)- where-  showLabel = (\(x:xs) -> toLower x:xs)-            . reverse-            . takeWhile (not . (==) '.')-            . reverse-            . show-{--            . tyConString-            . typeRepTyCon--}-            . typeOf-            . unProxy
Data/HList/Label5.hs view
@@ -1,6 +1,14 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}-+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+#if __GLASGOW_HASKELL__ > 906+{-# LANGUAGE LambdaCase #-}+#endif {- |+   Description: labels are any instance of Typeable+    The HList library     (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke@@ -18,19 +26,17 @@ 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+-- instance TypeEq x y b => HEq x y b   -- | Show label--instance Typeable x => ShowLabel x+instance {-# OVERLAPPABLE #-} Typeable (x :: *) => ShowLabel x  where-  showLabel = (\(x:xs) -> toLower x:xs)+  showLabel _ = (\l -> case l of [] -> [] ; (x:xs) -> toLower x:xs)             . reverse             . takeWhile (not . (==) '.')             . reverse@@ -39,4 +45,4 @@             . tyConString             . typeRepTyCon -}-            . typeOf+            . typeOf $ (error "Data.HList.Label5 has a strict typeOf" :: x)
+ Data/HList/Label6.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+{- |+   Description : labels using promoted strings (Symbol)++   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke+++   Yet another model of labels.++   Labels are promoted Strings or Integers "GHC.TypeLits" inside the+   'Label'. Needs ghc7.6 or higher.++   See <Data-HList-CommonMain.html#label6demo CommonMain#label6demo> for an example.++-}++module Data.HList.Label6 () where++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
@@ -0,0 +1,355 @@+{- |++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+for a lens and for other purposes. In other words, get the same+behavior as:++ > x = hLens (Label :: Label "x")+ > r ^. x++While still being able to extract the symbol \"x\" from x, so that things+like @x .=. 123@ could be acceptable. In this case we don't overload '.=.',+so instead you have to write @x .==. 123@.+++Elaboration of some ideas from edwardk.+-}+module Data.HList.Labelable+    (Labelable(..),+     LabeledOptic,+     (.==.),+++     -- * multiple lookups+     Projected(..), projected',++    -- * comparison with 'hLens'+    -- $comparisonWithhLensFunction++    -- * likely unneeded (re)exports+    LabeledCxt1,+    LabeledTo(LabeledTo),+    LabeledR(LabeledR),+    ToSym, EnsureLabel(toLabel), toLabelSym,+    Identity,+    LabelableTIPCxt,+    LabeledOpticType(..),++    LabeledOpticF,+    LabeledOpticP,+    LabeledOpticTo,+    ) where++++import Data.HList.HListPrelude+import Data.HList.FakePrelude+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)++{- | This alias is the same as Control.Lens.Optic, except the (->) in Optic+is a type parameter 'to' in LabeledOptic.++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))++data LabeledOpticType = LabelableLens | LabelablePrism | LabelableLabel++type family LabeledOpticF (ty :: LabeledOpticType) :: (* -> *) -> Constraint+type instance LabeledOpticF LabelableLens = Functor+type instance LabeledOpticF LabelablePrism = Applicative+type instance LabeledOpticF LabelableLabel = (~) Identity++type family LabeledOpticP (ty :: LabeledOpticType) :: (* -> * -> *) -> Constraint+type instance LabeledOpticP LabelableLens = (~) (->)+type instance LabeledOpticP LabelablePrism = Choice+type instance LabeledOpticP LabelableLabel = (~) (->)++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)+++{- |++[@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+    type LabelableTy r :: LabeledOpticType+    hLens' :: Label x -> LabeledOptic x r s t a b++data LabeledTo (x :: k) (a :: *) (b :: *) = LabeledTo deriving (Show)++data LabeledR (x :: [*]) = LabeledR++{- if __GLASGOW_HASKELL__ > 800+-- should this orphan instance really be supplied? ghc 8's+-- -XOverloadedLabels is uglier syntax than HListPP, and it+-- seems likely that other users of IsLabel probably define+-- an instance for (->) which will be chosen over this one+-- when labels are composed with (.),+-- (or alternatively there will be complaints about overlap)+instance (x ~ x', Labelable x r s t a b) => IsLabel x (LabeledOptic x' r s t a b) where+    fromLabel _ = hLens' (Label :: Label x)+-- endif+-}+++-- | make a @Lens (Record s) (Record t) a b@+instance HLens x Record s t a b+        => Labelable x Record s t a b where+            type LabelableTy Record = LabelableLens+            hLens' x = hLens x++-- | used with 'toLabel' and/or '.==.'+instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where+        type LabelableTy LabeledR = LabelableLabel+        hLens' _ = LabeledTo++-- | sets all type variables to dummy values: only the @Labeled x@+-- part is actually needed+type LabeledCxt1 s t a b = (s ~ '[], t ~ '[], a ~ (), b ~ ())++-- | make a @Prism (Variant s) (Variant t) a b@+instance (HPrism x s t a b,+          to ~ (->)) => Labelable x Variant s t a b where+    type LabelableTy Variant = LabelablePrism+    hLens' x s = hPrism x s++-- | @hLens' :: Label a -> Prism' (TIC s) a@+--+-- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@,+-- cannot have an instance of Labelable+--+-- Note: `x :: k` according to the instance head, but the instance body+-- forces the kind variable to be * later on. IE. (k ~ *)+instance (TICPrism s t a b, Label x ~ Label a,a ~ b, s ~ t,+          SameLength s t) =>+    Labelable (x :: k) TIC s t a b where+      type LabelableTy TIC = LabelablePrism+      hLens' _ = ticPrism+++-- | make a @Lens' (TIP s) a@.+--+-- 'tipyLens' provides a @Lens (TIP s) (TIP t) a b@, which tends to need+-- too many type annotations to be practical+instance LabelableTIPCxt x s t a b =>+    Labelable (x :: k) TIP s t a b where+    type LabelableTy TIP = LabelableLens+    hLens' x = hLens x++type LabelableTIPCxt x s t a b =+     (s ~ t, a ~ b, Label x ~ Label a,+      HLens x TIP s t a b)+++-- | modification of '.=.' which works with the labels from this module,+-- and those from "Data.HList.Label6". Note that this is not strictly a+-- generalization of '.=.', since it does not work with labels like+-- "Data.HList.Label3" which have the wrong kind.+l .==. v = toLabel l .=. v++infixr 4 .==.++-- | Get the Symbol out of a 'Label' or 'LabeledTo'+class ToSym label (s :: Symbol) | label -> s++instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3+    => ToSym (v1 v2 v3) x++instance ToSym (label x) x++{- | Convert a type to @Label :: Label blah@++> toLabel :: LabeledTo x _ _ -> Label (x :: Symbol)+> toLabel (hLens' lx)         = (lx :: Label x)+> toLabel :: Label x         -> Label x+> toLabel :: Proxy x         -> Label x++-}+class EnsureLabel x y | x -> y where+  toLabel :: x -> y++instance EnsureLabel (Label x) (Label (x :: k)) where+  toLabel _ = Label++instance EnsureLabel (Proxy x) (Label (x :: k)) where+  toLabel _ = Label++-- | get the Label out of a 'LabeledTo' (ie. `foobar when using HListPP).+instance ToSym (a b c) (x :: Symbol) => EnsureLabel (a b c) (Label x) where+  toLabel _ = Label+++-- | fix the `k` kind variable to 'Symbol'+toLabelSym label = toLabel label `asTypeOf` (Label :: Label (x :: Symbol))+++{- $comparisonWithhLensFunction++Note that passing around variables defined with 'hLens'' doesn't get+you exactly the same thing as calling 'hLens' at the call-site:++The following code needs to apply the @x@ for different @Functor+f =>@, so you would have to write a type signature (rank-2) to allow this+definition:++ > -- with the x defined using hLens'+ > let f x r = let+ >          a = r ^. x+ >          b = r & x .~ "6"+ >        in (a,b)++This alternative won't need a type signature++ > -- with the x defined as x = Label :: Label "x"+ > let f x r = let+ >          a = r ^. hLens x+ >          b = r & hLens x .~ "7"+ >        in (a,b)++It may work to use 'hLens'' instead of 'hLens' in the second code,+but that is a bit beside the point being made here.++The same points apply to the use of 'hPrism' over 'hLens''.++-}++{- | Sometimes it may be more convenient to operate on a record/variant+that only contains the fields of interest. 'projected' can then be used+to apply that function to a record that contains additional elements.+++>>> :set -XViewPatterns+>>> import Data.HList.RecordPuns+>>> let f [pun| (x y) |] = case x+y of z -> [pun| z |]+>>> :t f+f :: Num v =>+     Record '[Tagged "x" v, Tagged "y" v] -> Record '[Tagged "z" v]++>>> let r = (let x = 1; y = 2; z = () in [pun| x y z |])+>>> r+Record{x=1,y=2,z=()}++>>> r & sameLabels . projected %~ f+Record{x=1,y=2,z=3}+++++-}+class Projected r s t a b where+    projected :: (ty ~ LabelableTy r,+                LabeledOpticP ty p,+                LabeledOpticF ty f) => r a `p` f (r b) -> r s `p` f (r t)++-- | @Lens rs rt ra rb@+--+-- where @rs ~ Record s, rt ~ Record t, ra ~ Record a, rb ~ Record b@+instance (-- for Record s -> Record a+          H2ProjectByLabels (LabelsOf a) s a_ _s_minus_a,+          HRLabelSet a_, HRLabelSet a,+          HRearrange (LabelsOf a) a_ a,++          HLeftUnion b s bs, HRLabelSet bs,+          HRearrange (LabelsOf t) bs t, HRLabelSet t+        ) => Projected Record s t a b where+    projected f s = (\b -> hRearrange' (b .<++. s)) <$> f (hProjectByLabels' s :: Record a)++-- | @Prism (Variant s) (Variant t) (Variant a) (Variant b)@+instance (ExtendsVariant b t,+          ProjectVariant s a,+          ProjectExtendVariant s t,++          HLeftUnion b s bs, HRLabelSet bs,+          HRearrange (LabelsOf t) bs t)+      => Projected Variant s t a b where+    projected = prism extendsVariant+            (\s -> case projectVariant s of+                    Just a -> Right a+                    Nothing | Just t <- projectExtendVariant s -> Left t+                    _ -> error "Data.HList.Labelable.projected impossible"+                    -- projectExtendVariant gives Nothing when the element of+                    -- `t` that is actually stored in the variant comes+                    -- from the `b`. But in that case the projectVariant+                    -- above must have been Just+              )+++{- | @Lens' (Record s) (Record a)@++@Prism' (Variant s) (Variant a)@+-}+projected' s = isSimple projected s+++{- | Together with the instance below, this allows writing++@+'makeLabelable' "x y z"+p = x .*. y .*. z .*. 'emptyProxy'+@++Or with HListPP++@+p = `x .*. `y .*. `z .*. emptyProxy+@++instead of++> p = Proxy :: Proxy ["x","y","z"]++-}+instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy ('[] :: [*])) where+    type HExtendR (to p q) (Proxy ('[] :: [*])) = Proxy '[GetXFromLabeledTo to]+    (.*.) _ _ = Proxy++instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy (x ': xs)) where+    type HExtendR (to p q) (Proxy (x ': xs)) = Proxy (GetXFromLabeledTo to ': x ': xs)+    (.*.) _ _ = Proxy++-- | if the proxy has Data.HList.Label3."Lbl", then everything has to be+-- wrapped in Label to make the kinds match up.+instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy (Lbl n ns desc ': xs)) where+    type HExtendR (to p q) (Proxy (Lbl n ns desc ': xs))+        = Proxy (Label (GetXFromLabeledTo to) ': MapLabel (Lbl n ns desc ': xs))+    (.*.) _ _ = Proxy++type family GetXFromLabeledTo (to :: * -> * -> *) :: Symbol+type instance GetXFromLabeledTo (LabeledTo x) = x+
Data/HList/MakeLabels.hs view
@@ -1,111 +1,160 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell, FlexibleInstances, EmptyDataDecls #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} +{- | Description : Automate some of the ways to make labels. -{- | Making labels in the style of "Data.HList.Label4"+-} - The following TH splice+module Data.HList.MakeLabels (+    makeLabels,+    makeLabels3, ->  $(makeLabels ["getX","getY","draw"])+    -- * labels using kind 'Symbol'+    makeLabels6,+    makeLabelable,+    ) where -should expand into the following declarations+import Data.Typeable+import Data.HList.FakePrelude+import Data.HList.Label3+import Data.HList.Labelable -> data GetX;     getX     = proxy::Proxy GetX-> data GetY;     getY     = proxy::Proxy GetY-> data Draw;     draw     = proxy::Proxy Draw+import Language.Haskell.TH+import Data.Char+import Control.Monad --}+make_cname, make_dname :: String -> Name+make_cname (x:xs) = mkName ("Label" ++ toUpper x : xs)+make_cname _ = error "Data.HList.MakeLabels.make_cname: empty string" -module Data.HList.MakeLabels (makeLabels,label) where+make_dname (x:xs) = mkName (toLower x : xs)+make_dname _ = error "Data.HList.MakeLabels.make_dname: empty string" -import Data.HList.FakePrelude+dcl :: String -> Q [Dec]+dcl n = let+    c = make_cname n+    d = make_dname n -import Language.Haskell.TH.Ppr (pprint)-import Language.Haskell.TH.Syntax+    dd =+#if MIN_VERSION_template_haskell(2,12,0)+      dataD (return []) c [] Nothing [] [derivClause Nothing [ [t| Typeable |] ]]+#elif MIN_VERSION_template_haskell(2,11,0)+      dataD (return []) c [] Nothing [] (fmap (:[]) [t| Typeable |])+#else+      dataD (return []) c [] [] [''Typeable]+#endif -import Data.Char (toUpper, toLower)-import Control.Monad (liftM)+    labelSig = sigD d [t| Label $(conT c) |] -import Data.Typeable (Typeable)+    labelDec = valD+                  (varP d)+                  (normalB [| Label |])+                  [] -capitalize, uncapitalize :: String -> String-capitalize   (c:rest) = toUpper c : rest-uncapitalize (c:rest) = toLower c : rest+    showInst = instanceD+            (return [])+            [t| Show $(conT c) |]+            [valD (varP 'show)+                (normalB [| \_ -> n |])+                [] ] + in sequence [+        labelSig,+        labelDec, --- Make the name of the type constructor whose string representation--- is capitalized str-make_tname str = mkName $ capitalize str+        dd, --- Make the name of the value identifier whose string representation--- is uncapitalized str-make_dname str = mkName $ uncapitalize str+        showInst ] --- The template of our declaration. We will then replace all occurences--- of Foo with the desired name-dcl_template = [d| data Foo deriving Typeable; foo = proxy::Proxy Foo |] --- A very dirty traversal/replacement...+{- | -class ReplaceSyntax a where-    replace_name :: (Name,Name) -> (Name,Name) -> a -> a+Labels like "Data.HList.Label5". -instance ReplaceSyntax [Dec] where-    replace_name frm to dcls = map (replace_name frm to) dcls+ The following TH declaration splice should be placed at top-level, before the+ created values are used. Enable @-XTemplateHaskell@ too. -instance ReplaceSyntax Dec where-    replace_name (tfrom,dfrom) (tto,dto)-                 dcl@(DataD ctx n parms con othern) =-                     if tfrom == n then-                        DataD ctx tto parms con othern-                        else dcl-    replace_name (tfrom,dfrom) (tto,dto)-                 dcl@(ValD (VarP n) (NormalB body) []) =-          let n' = if n == dfrom then dto else n-          in ValD (VarP n')-                  (NormalB (replace_name (tfrom,dfrom) (tto,dto) body)) []+>  makeLabels ["getX","getY","draw","X"] -    replace_name (tfrom,dfrom) (tto,dto) dcl =-        error $ "Can't handle: " ++ show dcl+should expand into the following declarations +> data LabelGetX deriving Typeable+> data LabelGetY deriving Typeable+> data LabelDraw deriving Typeable+> data LabelX deriving Typeable -instance ReplaceSyntax Exp where-    replace_name from to (SigE exp tp) =-                     SigE (replace_name from to exp)-                          (replace_name from to tp)-    replace_name from to exp = exp+> getX = Label :: Label LabelGetX+> getY = Label :: Label LabelGetY+> draw = Label :: Label LabelDraw+> x    = Label :: Label LabelX +-}+makeLabels :: [String] -> Q [Dec]+makeLabels = fmap concat . mapM dcl -instance ReplaceSyntax Type where-    replace_name (tfrom,dfrom) (tto,dto) tp@(ConT n) =-        if n == tfrom then (ConT tto) else tp-    replace_name from to (AppT t1 t2) =-        (AppT (replace_name from to t1) (replace_name from to t2)) --- | Our main function-makeLabels :: [String] -> Q [Dec]-makeLabels = liftM concat . sequence . map repl- where- repl n = liftM (replace_name from (to n)) dcl_template- from = (make_tname "foo",make_dname "foo")- to n = (make_tname n,make_dname n)+-- | for "Data.HList.Label3"+makeLabels3 :: String -- ^ namespace+    -> [String] -- ^ labels+    -> Q [Dec]+makeLabels3 ns (k:ks) =+    let pt1 = fmap (concatMap (drop 2)) $ mapM dcl (ns : k : ks) --- | Make a single label-label :: String -> Q [Dec]-label s = makeLabels [s]+        sq1 = valD (varP (make_dname k))+                (normalB [| firstLabel (undefined :: $(conT (make_cname ns)))+                                       (undefined :: $(conT (make_cname k))) |])+                [] --- Show the code expression-show_code cde = runQ cde >>= putStrLn . pprint+        sqs = [ valD (varP (make_dname k2))+                (normalB [| nextLabel $(varE (make_dname k1))+                                    (undefined :: $(conT (make_cname k2))) |])+                [] -{--t1 = show_code [d| data Foo |]+                | (k1,k2) <- zip (k:ks) ks ] -t2 = showName $ mkName "Foo"+    in fmap concat $ sequence [ pt1, sequence (sq1 : sqs) ]+-- possibly there is a better option+makeLabels3 ns [] = fail ("makeLabels3 "++ ns ++ " []") -t3 = show_code $-     liftM (replace_name-            (make_tname "foo",make_dname "foo")-            (make_tname "bar",make_dname "bar")) dcl_template+{- | 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 |]) []] -t4 = show_code $ makeLabels ["getX","getY","draw"]++{- | @makeLabelable \"x y z\"@ expands out to++> x = hLens' (Label :: Label "x")+> y = hLens' (Label :: Label "y")+> z = hLens' (Label :: Label "z")++Refer to "Data.HList.Labelable" for usage.++-}+makeLabelable :: String -> Q [Dec]+makeLabelable xs = fmap concat $ mapM makeLabel1 (words xs)+    where+        -- a bit indirect, ghc-7.6 TH is a bit too eager to reject+        -- mis-matched kind variables+        makeLabel1 x = sequence+              [+                sigD (mkName x) makeSig,+                valD (varP (mkName x)) (normalB (varE 'hLens' `appE` lt))+                            []+                ]+            where lt = [| Label :: $([t| Label $l |]) |]+                  l = litT (strTyLit x)++                  makeSig = [t| forall r s t a b. (Labelable $l r s t a b) =>+                              LabeledOptic $l r s t a b+                              |]
Data/HList/Record.hs view
@@ -1,568 +1,1343 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}--{- |-   The HList library--   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Extensible records--   The are different models of labels that go with this module;-   see:--   * "Data.HList.Label1"--   * "Data.HList.Label2"--   * "Data.HList.Label3"--   * "Data.HList.Label4"--   * "Data.HList.Label5"--}--module Data.HList.Record-(-    -- * Records--    -- ** Labels-    -- $labels-    LVPair(..),-    labelLVPair,-    newLVPair,--    -- ** Record-    Record(..),-    mkRecord,-    emptyRecord,--    -- *** Getting Labels-    RecordLabels,-    recordLabels,-    recordLabels',--    -- *** Getting Values-    RecordValues(..),-    recordValues,--    -- * Operations-    -- ** Show-    -- | A corresponding 'Show' instance exists as-    ---    -- > show x = "Record {" ++ showComponents "" x ++ "}"-    ShowComponents(..),-    ShowLabel(..),--    -- ** Lookup-    HasField(..),-    HasField'(..),--    -- ** Delete-    -- | 'hDeleteAtLabel' @label record@-    hDeleteAtLabel,--    -- ** Update-    -- | 'hUpdateAtLabel' @label value record@-    hUpdateAtLabel,-    hTPupdateAtLabel,--    -- ** Rename Label-    hRenameLabel,--    -- ** Projection-    -- $projection-    hProjectByLabels,-    hProjectByLabels2,--    -- ** Unions-    -- *** Left-    HLeftUnion(hLeftUnion),-    HLeftUnionBool(hLeftUnionBool),--    -- *** Symmetric-    -- $symmetricUnion-    UnionSymRec(unionSR),--    -- ** Reorder Labels-    hRearrange,--    -- ** Extension-    -- | 'hExtend', 'hAppend'--    -- * Unclassified-    -- | Probably internals, that may not be useful-    DuplicatedLabel(..),-    ExtraField(..),-    FieldNotFound(..),-    H2ProjectByLabels(h2projectByLabels),-    H2ProjectByLabels'(h2projectByLabels'),-    HLabelSet,-    HLabelSet',-    HRLabelSet,-    HRLabelSet',-    HRearrange(hRearrange2),-    HRearrange'(hRearrange2'),-    UnionSymRec'(..)-) where---import Data.HList.FakePrelude-import Data.HList.HListPrelude-import Data.HList.HArray---{-----------------------------------------------------------------------------}---- $labels Record types as label-value pairs, where label is purely phantom.--- Thus the run-time representation of a field is the same as that of--- its value, and the record, at run-time, is indistinguishable from--- the HList of field values. At run-time, all information about the--- labels is erased.---- | Field of label l with value type v-newtype LVPair l v = LVPair { valueLVPair :: v } deriving Eq---- | Label accessor-labelLVPair :: LVPair l v -> l-labelLVPair = undefined--newLVPair :: l -> v -> LVPair l v-newLVPair _ = LVPair--newtype Record r = Record r deriving Eq----- | Build a record-mkRecord :: HRLabelSet r => r -> Record r-mkRecord = Record----- | Build an empty record-emptyRecord :: Record HNil-emptyRecord = mkRecord HNil----- | Propery of a proper label set for a record: no duplication of labels--class HRLabelSet ps-instance HRLabelSet HNil-instance HRLabelSet (HCons x HNil)-instance ( HEq l1 l2 leq-         , HRLabelSet' l1 v1 l2 v2 leq r-         ) => HRLabelSet (HCons (LVPair l1 v1) (HCons (LVPair l2 v2) r))--class HRLabelSet' l1 v1 l2 v2 leq r-instance ( HRLabelSet (HCons (LVPair l2 v2) r)-         , HRLabelSet (HCons (LVPair l1 v1) r)-         ) => HRLabelSet' l1 v1 l2 v2 HFalse r-instance ( Fail (DuplicatedLabel l1) ) => HRLabelSet' l1 v1 l2 v2 HTrue r--{--instance (HZip ls vs ps, HLabelSet ls) => HRLabelSet ps--}--class HLabelSet ls-instance HLabelSet HNil-instance (HMember x ls xmem, HLabelSet' x ls xmem) => HLabelSet (HCons x ls)--class HLabelSet' x ls xmem-instance HLabelSet ls => HLabelSet' x ls HFalse--data DuplicatedLabel l = DuplicatedLabel l-instance Fail (DuplicatedLabel x) => HLabelSet' x ls HTrue---- | Construct the (phantom) list of labels of the record.------ This is a purely type-level function.-class RecordLabels r ls | r -> ls-instance RecordLabels HNil HNil-instance RecordLabels r' ls-      => RecordLabels (HCons (LVPair l v) r') (HCons l ls)--recordLabels' :: RecordLabels r ls => r -> ls-recordLabels' r = undefined--recordLabels :: RecordLabels r ls => Record r -> ls-recordLabels (Record r) = recordLabels' r---- | Construct the list of values of the record.-class RecordValues r ls | r -> ls-    where recordValues' :: r -> ls-instance RecordValues HNil HNil-    where recordValues' _ = HNil-instance RecordValues r' vs-      => RecordValues (HCons (LVPair l v) r') (HCons v vs)-    where recordValues' ~(HCons (LVPair v) r') = HCons v (recordValues' r')--recordValues :: RecordValues r vs => Record r -> vs-recordValues (Record r) = recordValues' r----{-----------------------------------------------------------------------------}---- 'Show' instance to appeal to normal records--instance ShowComponents r => Show (Record r)- where-  show (Record r) =  "Record{"-                  ++ showComponents "" r-                  ++ "}"--class ShowComponents l- where-  showComponents :: String -> l -> String--instance ShowComponents HNil- where-  showComponents _ HNil = ""--instance ( ShowLabel l-         , Show v-         , ShowComponents r-         )-      =>   ShowComponents (HCons (LVPair l v) r)- where-  showComponents comma (HCons f@(LVPair v) r)-     =  comma-     ++ showLabel (labelLVPair f)-     ++ "="-     ++ show v-     ++ showComponents "," r--class ShowLabel l- where-  showLabel :: l -> String---{-----------------------------------------------------------------------------}---- Extension--instance HRLabelSet (HCons (LVPair l v) r)-    => HExtend (LVPair l v) (Record r) (Record (HCons (LVPair l v) r))- where-  hExtend f (Record r) = mkRecord (HCons f r)---{-----------------------------------------------------------------------------}---- Concatenation--instance ( HRLabelSet r''-         , HAppend r r' r''-         )-    => HAppend (Record r) (Record r') (Record r'')- where-  hAppend (Record r) (Record r') = mkRecord (hAppend r r')---{-----------------------------------------------------------------------------}---- Lookup------ |--- This is a baseline implementation.--- We use a helper class, HasField, to abstract from the implementation.---- | Because 'hLookupByLabel' is so frequent and important, we implement--- it separately, more efficiently. The algorithm is familiar assq, only--- the comparison operation is done at compile-time-class HasField l r v | l r -> v-  where-    hLookupByLabel:: l -> r -> v--{--instance ( RecordLabels r ls-         , HFind l ls n-         , HLookupByHNat n r (LVPair l v)-         ) => HasField l (Record r) v-  where-    hLookupByLabel l (Record r) = v-      where-        ls = recordLabels' r-        n = hFind l ls-        (LVPair v) = hLookupByHNat n r---}----instance HasField l r v => HasField l (Record r) v where-    hLookupByLabel l (Record r) = hLookupByLabel l r--class HasField' b l r v | b l r -> v where-    hLookupByLabel':: b -> l -> r -> v--instance (HEq l l' b, HasField' b l (HCons (LVPair l' v') r) v)-    => HasField l (HCons (LVPair l' v') r) v where-    hLookupByLabel l r@(HCons f' _) =-             hLookupByLabel' (hEq l (labelLVPair f')) l r--instance HasField' HTrue l (HCons (LVPair l v) r) v where-    hLookupByLabel' _ _ (HCons (LVPair v) _) = v-instance HasField l r v => HasField' HFalse l (HCons fld r) v where-    hLookupByLabel' _ l (HCons _ r) = hLookupByLabel l r----{-----------------------------------------------------------------------------}---- Delete--hDeleteAtLabel :: (H2ProjectByLabels (HCons e HNil) t t1 t2) =>e -> Record t -> Record t2-hDeleteAtLabel l (Record r) = Record r'- where-  (_,r')  = h2projectByLabels (HCons l HNil) r---{-----------------------------------------------------------------------------}---- Update--hUpdateAtLabel :: (HUpdateAtHNat n (LVPair l v) t l',HFind l ls n,RecordLabels t ls) =>l -> v -> Record t -> Record l'-hUpdateAtLabel l v (Record r) = Record r'- where-  n    = hFind l (recordLabels' r)-  r'   = hUpdateAtHNat n (newLVPair l v) r---{-----------------------------------------------------------------------------}--- Projection---- $projection--- It is also an important operation: the basis of many--- deconstructors -- so we try to implement it efficiently.----- | @hProjectByLabels ls r@ returns @r@ with only the labels in @ls@ remaining-hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) => ls -> Record t -> Record a-hProjectByLabels ls (Record r) = mkRecord (fst $ h2projectByLabels ls r)---- | See 'H2ProjectByLabels'-hProjectByLabels2 :: (H2ProjectByLabels ls t t1 t2, HRLabelSet t1, HRLabelSet t2) =>ls -> Record t -> (Record t1, Record t2)-hProjectByLabels2 ls (Record r) = (mkRecord rin, mkRecord rout)-   where (rin,rout) = h2projectByLabels ls r---- | /Invariant/:------  > r === rin `disjoint-union` rout---  > labels rin === ls---  >     where (rin,rout) = hProjectByLabels ls r-class H2ProjectByLabels ls r rin rout | ls r -> rin rout where-    h2projectByLabels :: ls -> r -> (rin,rout)--instance H2ProjectByLabels HNil r HNil r where-    h2projectByLabels _ r = (HNil,r)--instance H2ProjectByLabels (HCons l ls) HNil HNil HNil where-    h2projectByLabels _ _ = (HNil,HNil)--instance (HMemberM l' (HCons l ls) b,-          H2ProjectByLabels' b (HCons l ls) (HCons (LVPair l' v') r') rin rout)-    => H2ProjectByLabels (HCons l ls) (HCons (LVPair l' v') r') rin rout where-    -- h2projectByLabels = h2projectByLabels' (undefined::b)-    -- The latter is solely for the Hugs benefit-    h2projectByLabels ls r@(HCons _ _) =h2projectByLabels' (undefined::b) ls r-      -- where b = hMember (labelLVPair f') ls--class H2ProjectByLabels' b ls r rin rout | b ls r -> rin rout where-    h2projectByLabels' :: b -> ls -> r -> (rin,rout)--instance H2ProjectByLabels ls' r' rin rout =>-    H2ProjectByLabels' (HJust ls') ls (HCons f' r') (HCons f' rin) rout where-    h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout)-        where (rin,rout) = h2projectByLabels (undefined::ls') r--instance H2ProjectByLabels ls r' rin rout =>-    H2ProjectByLabels' HNothing ls (HCons f' r') rin (HCons f' rout) where-    h2projectByLabels' _ ls (HCons x r) = (rin, HCons x rout)-        where (rin,rout) = h2projectByLabels ls r---{-----------------------------------------------------------------------------}---- | Rename the label of record-hRenameLabel :: (HRLabelSet (HCons (LVPair l v) t2),HasField e t1 v,H2ProjectByLabels (HCons e HNil) t1 t t2) =>-    e -> l -> Record t1 -> Record (HCons (LVPair l v) t2)-hRenameLabel l l' r = r''- where-  v   = hLookupByLabel l r-  r'  = hDeleteAtLabel l r-  r'' = hExtend (newLVPair l' v) r'---{-----------------------------------------------------------------------------}---- | A variation on 'hUpdateAtLabel': type-preserving update.-hTPupdateAtLabel :: (HasField l t a,HUpdateAtHNat n (LVPair l a) t l',HFind l ls n,RecordLabels t ls) =>-    l -> a -> Record t -> Record l'-hTPupdateAtLabel l v r = hUpdateAtLabel l v r- where-   te :: a -> a -> ()-   te _ _ = ()-   _ = te v (hLookupByLabel l r)--{- ^--We could also say:--> hTPupdateAtLabel l v r = hUpdateAtLabel l v r `asTypeOf` r--Then we were taking a dependency on Haskell's type equivalence.-This would also constrain the actual implementation of hUpdateAtLabel.---}--{-----------------------------------------------------------------------------}---- | Subtyping for records-instance ( RecordLabels r' ls-         , H2ProjectByLabels ls r r' rout-         )-    => SubType (Record r) (Record r')---{-----------------------------------------------------------------------------}---- Left Union--class  HLeftUnion r r' r'' | r r' -> r''- where hLeftUnion :: r -> r' -> r''--instance HLeftUnion r (Record HNil) r- where   hLeftUnion r _ = r--instance ( RecordLabels r ls-         , HMember l ls b-         , HLeftUnionBool b r (LVPair l v) r'''-         , HLeftUnion (Record r''') (Record r') r''-         )-           => HLeftUnion (Record r) (Record (HCons (LVPair l v) r')) r''-  where-   hLeftUnion (Record r) (Record (HCons f r')) = r''-    where-     b       = hMember (labelLVPair f) (recordLabels' r)-     r'''    = hLeftUnionBool b r f-     r''     = hLeftUnion (Record r''') (Record r')--class  HLeftUnionBool b r f r' | b r f -> r'- where hLeftUnionBool :: b -> r -> f -> r'--instance HLeftUnionBool HTrue r f r-   where hLeftUnionBool _ r _  = r--instance HLeftUnionBool HFalse r f (HCons f r)-   where hLeftUnionBool _ r f = HCons f r---{-----------------------------------------------------------------------------}--- $symmetricUnion--- Compute the symmetric union of two records r1 and r2 and--- return the pair of records injected into the union (ru1, ru2).------ To be more precise, we compute the symmetric union /type/ @ru@--- of two record /types/ @r1@ and @r2@. The emphasis on types is important.------ The two records (ru1,ru2) in the result of 'unionSR' have the same--- type ru, but they are generally different values.--- Here the simple example: suppose------ >  r1 = (Label .=. True)  .*. emptyRecord--- >  r2 = (Label .=. False) .*. emptyRecord------ Then 'unionSR' r1 r2 will return (r1,r2). Both components of the result--- are different records of the same type.--------- To project from the union ru, use 'hProjectByLabels'.--- It is possible to project from the union obtaining a record--- that was not used at all when creating the union.------ We do assure however that if @unionSR r1 r2@ gave @(r1u,r2u)@,--- then projecting r1u onto the type of r1 gives the /value/ identical--- to r1. Ditto for r2.--class UnionSymRec r1 r2 ru | r1 r2 -> ru where-    unionSR :: r1 -> r2 -> (ru, ru)--instance UnionSymRec r1 (Record HNil) r1 where-    unionSR r1 _ = (r1, r1)--instance ( RecordLabels r1 ls-         , HMember l ls b-         , UnionSymRec' b (Record r1) (LVPair l v) (Record r2') ru-         )-    => UnionSymRec (Record r1) (Record (HCons (LVPair l v) r2')) ru-    where-    unionSR r1 (Record (HCons f r2')) =-        unionSR' (undefined::b) r1 f (Record r2')--class UnionSymRec' b r1 f2 r2' ru | b r1 f2 r2' -> ru where-    unionSR' :: b -> r1 -> f2 -> r2'  -> (ru, ru)---- | 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' (Record ru),-          HasField l2 ru v2,-          HUpdateAtHNat n (LVPair l2 v2) ru ru,-          RecordLabels ru ls,-          HFind l2 ls n)-    => UnionSymRec' HTrue r1 (LVPair l2 v2) r2' (Record ru) where-    unionSR' _ r1 (LVPair v2) r2' = (ul, ur')-       where (ul,ur) = unionSR r1 r2'-             ur' = hTPupdateAtLabel (undefined::l2) v2 ur---instance (UnionSymRec r1 r2' (Record ru),-          HExtend f2 (Record ru) (Record (HCons f2 ru)))-    => UnionSymRec' HFalse r1 f2 r2' (Record (HCons f2 ru)) where-    unionSR' _ r1 f2 r2' = (ul', ur')-       where (ul,ur) = unionSR r1 r2'-             ul' = hExtend f2 ul-             ur' = hExtend f2 ur--{-----------------------------------------------------------------------------}--- | 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--- permutation of ls.-hRearrange :: (HLabelSet ls, HRearrange ls r r') => ls -> Record r -> Record r'-hRearrange ls (Record r) = Record $ hRearrange2 ls r---- | Helper class for 'hRearrange'-class HRearrange ls r r' | ls r -> r' where-    hRearrange2 :: ls -> r -> r'--instance HRearrange HNil HNil HNil where-   hRearrange2 _ _ = HNil--instance (H2ProjectByLabels (HCons l HNil) r rin rout,-          HRearrange' l ls rin rout r') =>-        HRearrange (HCons l ls) r r' where-   hRearrange2 ~(HCons l ls) r = hRearrange2' l ls rin rout-      where (rin, rout) = h2projectByLabels (HCons l HNil) r---- | Helper class 2 for 'hRearrange'-class HRearrange' l ls rin rout r' | l ls rin rout -> r' where-    hRearrange2' :: l -> ls -> rin -> rout -> r'-instance HRearrange ls rout r' =>-        HRearrange' l ls (HCons (LVPair l v) HNil) rout (HCons (LVPair l v) r') where-   hRearrange2' _ ls (HCons lv@(LVPair v) HNil) rout = HCons (LVPair v `asTypeOf` lv) (hRearrange2 ls rout)--data ExtraField l = ExtraField-data FieldNotFound l = FieldNotFound---- | For improved error messages-instance Fail (FieldNotFound l) => -        HRearrange' l ls HNil rout (FieldNotFound l) where-   hRearrange2' _ _ _ _ = FieldNotFound---- | For improved error messages-instance Fail (ExtraField l) => -          HRearrange HNil (HCons (LVPair l v) a) (ExtraField l) where-   hRearrange2 _ _ = ExtraField+{-# LANGUAGE CPP #-}+{- |+   The HList library++   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Extensible records++   The three-ish models of labels that go with this module;++   * "Data.HList.Label3"++   * "Data.HList.Label5"++   * "Data.HList.Label6"++   * "Data.HList.Labelable"+++   These used to work:++   * "Data.HList.Label1"++   * "Data.HList.Label2"++   * "Data.HList.Label4"++-}++module Data.HList.Record+(+    -- ** labels used for doctests+    -- $setup++    -- * Records++    -- ** Labels+    -- $labels+    module Data.Tagged,+    (.=.),++    -- ** Record+    Record(..),+    mkRecord,+    emptyRecord,+    hEndR,+    hEndP,++    hListRecord, hListRecord',++    -- *** Getting Labels+    LabelsOf,+    labelsOf,+    asLabelsOf,++    -- *** Getting Values+    RecordValues(..),+    recordValues,+    hMapTaggedFn,++    unlabeled0,++    Unlabeled,+    unlabeled,+    Unlabeled',+    unlabeled',++    -- * Operations+    -- ** Show+    -- | A corresponding 'Show' instance exists as+    --+    -- > show x = "Record {" ++ showComponents "" x ++ "}"+    ShowComponents(..),+    ShowLabel(..),++    -- ** Extension+    -- | 'hExtend', 'hAppend'+    (.*.),++    -- ** Delete+    -- | 'hDeleteAtLabel' @label record@+    (.-.),+    HDeleteLabels(..),++    -- ** Lookup/update+    -- $lens+    HLens(hLens),++    -- ** Lookup+    HasField(..),+    HasFieldM(..),+    (.!.),++    -- ** Update+    (.@.),+    HUpdateAtLabel(hUpdateAtLabel),+    -- *** type-preserving versions+    -- | 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),+    (.<++.),++    -- *** Symmetric+    -- $symmetricUnion+    UnionSymRec(unionSR),+++    -- ** Reorder Labels+    hRearrange,+    hRearrange',++    -- *** 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,++    -- * Unclassified++    -- | Probably internals, that may not be useful+#if __GLASGOW_HASKELL__ != 706+    zipTagged,+#endif+    HasField'(..),+    DemoteMaybe,+    HasFieldM1(..),+    H2ProjectByLabels(h2projectByLabels),+    H2ProjectByLabels'(h2projectByLabels'),+    HLabelSet,+    HLabelSet',+    HRLabelSet,+    HAllTaggedLV,+    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.Label3 (MapLabel)++import Data.Tagged+import Control.Monad++import Text.ParserCombinators.ReadP++import LensDefs++import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif+-- imports for doctest/examples+import Data.HList.Label6 ()+import Data.HList.TypeEqO ()++{- $setup++>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let z = Label :: Label "z"++-}++-- --------------------------------------------------------------------------++-- $labels Record types as label-value pairs, where label is purely phantom.+-- Thus the run-time representation of a field is the same as that of+-- its value, and the record, at run-time, is indistinguishable from+-- the HList of field values. At run-time, all information about the+-- labels is erased.+--+-- The type from "Data.Tagged" is used.++-- | Label accessor+labelLVPair :: Tagged l v -> Label l+labelLVPair _ = Label++newLVPair :: Label l -> v -> Tagged l v+newLVPair _ = Tagged++++infixr 4 .=.+{-|++  Create a value with the given label. Analagous to a data+  constructor such as 'Just', 'Left', or 'Right'. Higher fixity+  than record-modification operations like ('.*.'), ('.-.'), etc. to+  support expression like the below w/o parentheses:++  >>> x .=. "v1" .*. y .=. '2' .*. emptyRecord+  Record{x="v1",y='2'}++-}+(.=.) :: Label l -> v -> Tagged l v+l .=. v = newLVPair l v+++newtype Record (r :: [*]) = Record (HList r)++deriving instance Semigroup (HList r) => Semigroup (Record r)+deriving instance Monoid (HList r) => Monoid (Record r)+deriving instance (Eq (HList r)) => Eq (Record r)+deriving instance (Ord (HList r)) => Ord (Record r)+deriving instance (Ix (HList r)) => Ix (Record r)+deriving instance (Bounded (HList r)) => Bounded (Record r)+++-- | Build a record+mkRecord :: HRLabelSet r => HList r -> Record r+mkRecord = Record++-- | @HRLabelSet t => Iso (HList s) (HList t) (Record s) (Record t)@+hListRecord x = isoNewtype mkRecord (\(Record r) -> r) x++-- | @Iso' (HList s) (Record s)@+hListRecord' x = isSimple hListRecord x++-- | Build an empty record+emptyRecord :: Record '[]+emptyRecord = mkRecord HNil++-- | @Iso (Record s) (Record t) (HList a) (HList b)@+--+-- @view unlabeled == 'recordValues'@+unlabeled0 x = sameLabels (iso recordValues hMapTaggedFn x)+++unlabeled :: (Unlabeled x y, Profunctor p, Functor f) =>+    (HList (RecordValuesR x) `p` f (HList (RecordValuesR y))) ->+    (Record x `p` f (Record y))+unlabeled x = sameLength (unlabeled0 (sameLength x))++type Unlabeled x y =+      (HMapCxt HList TaggedFn (RecordValuesR y) y,+       RecordValues x, RecordValues y,+       SameLength (RecordValuesR x) (RecordValuesR y),+       SameLength x y, SameLabels x y,+       HAllTaggedLV x, HAllTaggedLV y)+type Unlabeled' x = Unlabeled x x++++-- | @Unlabeled' x => Iso' (Record x) (HList (RecordValuesR x))@+unlabeled' :: (Unlabeled' x, Profunctor p, Functor f) =>+    (HList (RecordValuesR x) `p` f (HList (RecordValuesR x))) ->+    (Record x `p` f (Record x))+unlabeled' = unlabeled++{- | @Iso (Record s) (Record t) (Record a) (Record b)@, such that+@relabeled = unlabeled . from unlabeled@++in other words, pretend a record has different labels, but the same values.++-}+class Relabeled r where+  relabeled :: forall p f s t a b.+      (HMapTaggedFn (RecordValuesR s) a,+       HMapTaggedFn (RecordValuesR b) t,+       SameLengths '[s,a,t,b],+       RecordValuesR t ~ RecordValuesR b,+       RecordValuesR s ~ RecordValuesR a,+       RecordValues b, RecordValues s,+       Profunctor p,+       Functor f+       ) => r a `p` f (r b) -> r s `p` f (r t)++instance Relabeled Record where+  relabeled = iso+    (\ s -> hMapTaggedFn (recordValues s))+    (\ b -> hMapTaggedFn (recordValues b))+    -- isoNewtype should be safe here, but there are no guarantees+    -- http://stackoverflow.com/questions/24222552++-- | @Iso' (Record s) (Record a)@+--+-- such that @RecordValuesR s ~ RecordValuesR a@+relabeled' x = isSimple relabeled x++data TaggedFn = TaggedFn+instance (tx ~ Tagged t x) => ApplyAB TaggedFn x tx where+    applyAB _ = Tagged++type HMapTaggedFn l r =+    (HMapCxt HList TaggedFn l r,+     RecordValuesR r ~ l,+     RecordValues r)++-- | \"inverse\" to 'recordValues'+hMapTaggedFn :: HMapTaggedFn a b => HList a -> Record b+hMapTaggedFn = Record . hMap TaggedFn++-- | Property of a proper label set for a record: no duplication of labels,+-- and every element of the list is @Tagged label value@++data DuplicatedLabel l++class (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*])+instance (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => 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 ( HEqK l1 l2 leq+         , HLabelSet' l1 l2 leq r+         ) => HLabelSet (l1 ': l2 ': r)++class HLabelSet' l1 l2 (leq::Bool) r+instance ( HLabelSet (l2 ': r)+         , HLabelSet (l1 ': r)+         ) => HLabelSet' l1 l2 False r+instance ( Fail (DuplicatedLabel l1) ) => HLabelSet' l1 l2 True r++-- | 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++labelsOf :: hlistOrRecord l -> Proxy (LabelsOf l)+labelsOf _ = 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 SameLength r (RecordValuesR r)+      => RecordValues (r :: [*]) where+  type RecordValuesR r :: [*]+  recordValues' :: HList r -> HList (RecordValuesR r)++instance RecordValues '[] where+  type RecordValuesR '[] = '[]+  recordValues' _ = HNil+instance (SameLength' r (RecordValuesR r),+          SameLength' (RecordValuesR r) r, RecordValues r) => RecordValues (Tagged l v ': r) where+   type RecordValuesR (Tagged l v ': r) = v ': RecordValuesR r+   recordValues' (HCons (Tagged v) r) = HCons v (recordValues' r)++recordValues :: RecordValues r => Record r -> HList (RecordValuesR r)+recordValues (Record r) = recordValues' r++{- 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++type RecordValues r rv = HMapCxt HUntag r rv+-}++-- --------------------------------------------------------------------------++-- 'Show' instance to appeal to normal records++instance ShowComponents r => Show (Record r) where+  show (Record r) =  "Record{"+                  ++ showComponents "" r+                  ++ "}"++class ShowComponents l where+  showComponents :: String -> HList l -> String++instance ShowComponents '[] where+  showComponents _ _ = ""++instance ( ShowLabel l+         , Show v+         , ShowComponents r+         )+      =>   ShowComponents (Tagged l v ': r) where+  showComponents comma (HCons f@(Tagged v) r)+     =  comma+     ++ showLabel ((labelLVPair f) :: Label l)+     ++ "="+     ++ show v+     ++ showComponents "," r+++-- --------------------------------------------------------------------------++-- 'Read' instance to appeal to normal records+++data ReadComponent = ReadComponent Bool -- ^ include comma?++instance (Read v, ShowLabel l,+          x ~ Tagged l v,+          ReadP x ~ y) =>+  ApplyAB ReadComponent (Proxy x) y where+    applyAB (ReadComponent comma) _ = do+      when comma (() <$ string ",")+      _ <- string (showLabel (Label :: Label l))+      _ <- string "="+      v <- readS_to_P reads+      return (Tagged v)+++instance (HMapCxt HList ReadComponent (AddProxy rs) bs,+          ApplyAB ReadComponent (Proxy r) readP_r,+          HProxies rs,+          HSequence ReadP (readP_r ': bs) (r ': rs),+          readP_r ~ ReadP (Tagged l v),++          -- ghc-8.0.2 needs these. The above constraints+          -- should imply them+          r ~ Tagged l v,+          ShowLabel l,+          Read v,+          HSequence ReadP bs rs+          ) => Read (Record (r ': rs)) where+    readsPrec _ = readP_to_S $ do+        _ <- string "Record{"+        content <- hSequence parsers+        _ <- string "}"+        return (Record content)++      where+        rs :: HList (AddProxy rs)+        rs = hProxies++        readP_r :: readP_r+        readP_r = applyAB+                      (ReadComponent False)+                      (Proxy :: Proxy r)++        parsers = readP_r `HCons` (hMap (ReadComponent True) rs :: HList bs)++++++-- --------------------------------------------------------------------------++-- Extension++instance HRLabelSet (t ': r)+    => HExtend t (Record r) where+  type HExtendR t (Record r) = Record (t ': r)+  f .*. (Record r) = mkRecord (HCons f r)+++-- * For records++{-|++  [@(.*.)@]+           Add a field to a record. Analagous to (++) for+           lists.++  > record .*. field1+  >        .*. field2++-}++-- --------------------------------------------------------------------------++-- Concatenation++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 (HAppendListR r1 r2)+-- --------------------------------------------------------------------------++-- Lookup+--+-- |+-- This is a baseline implementation.+-- We use a helper class, HasField, to abstract from the implementation.++-- | Because 'hLookupByLabel' is so frequent and important, we implement+-- it separately, more efficiently. The algorithm is familiar assq, only+-- the comparison operation is done at compile-time+class HasField (l::k) r v | l r -> v where+    hLookupByLabel:: Label l -> r -> v++{- alternative "straightforward" implementation+instance ( LabelsOf r ~ ls+         , HFind l ls n+         , HLookupByHNat n r+         , HLookupByHNatR n r ~ LVPair l v+         ) => HasField l (Record r) v+  where+    hLookupByLabel l (Record r) = v+      where+        (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++>>> hLookupByLabelM y r ()+()++>>> hLookupByLabelM x r ()+"the x value"++++-}+class HasFieldM (l :: k) r (v :: Maybe *) | l r -> v where+    hLookupByLabelM :: Label l+          -> r -- ^ Record (or Variant,TIP,TIC)+          -> t -- ^ default value+          -> DemoteMaybe t v++type family DemoteMaybe (d :: *) (v :: Maybe *) :: *+type instance DemoteMaybe d (Just a) = a+type instance DemoteMaybe d Nothing = d++class HasFieldM1 (b :: Maybe [*]) (l :: k) r v | b l r -> v where+    hLookupByLabelM1 :: Proxy b -> Label l -> r -> t -> DemoteMaybe t v++instance (HMemberM (Label l) (LabelsOf xs) b,+          HasFieldM1 b l (r xs) v)  => HasFieldM l (r xs) v where+    hLookupByLabelM = hLookupByLabelM1 (Proxy :: Proxy b)++instance HasFieldM1 Nothing l r Nothing where+    hLookupByLabelM1 _ _ _ t = t++instance HasField l r v => HasFieldM1 (Just b) l r (Just v) where+    hLookupByLabelM1 _ l r _t = hLookupByLabel l r++++instance (HEqK l l1 b, HasField' b l (Tagged l1 v1 ': r) v)+    => HasField l (Record (Tagged l1 v1 ': r)) v where+    hLookupByLabel l (Record r) =+             hLookupByLabel' (Proxy::Proxy b) l r++-- | XXX+instance (t ~ Any, Fail (FieldNotFound l ())) => HasField l (Record '[]) t where+    hLookupByLabel _ _ = error "Data.HList.Record.HasField: Fail instances should not exist"+++class HasField' (b::Bool) (l :: k) (r::[*]) v | b l r -> v where+    hLookupByLabel':: Proxy b -> Label l -> HList r -> v++instance HasField' True l (Tagged l v ': r) v where+    hLookupByLabel' _ _ (HCons (Tagged v) _) = v+instance HasField l (Record r) v => HasField' False l (fld ': r) v where+    hLookupByLabel' _ l (HCons _ r) = hLookupByLabel l (Record r)++++infixr 9 .!.+{- |+  Lookup a value in a record by its label. Analagous to (!!), the+  list indexing operation. Highest fixity, like ('!!').++  >>> :{+  let record1 = x .=. 3 .*.+                y .=. 'y' .*.+                emptyRecord+  :}+++  >>> record1 .!. x+  3++  >>> record1 .!. y+  'y'+++  >>> :{+  let r2 = y .=. record1 .!. x .*.+           z .=. record1 .!. y .*.+           emptyRecord+  :}++  >>> r2+  Record{y=3,z='y'}++  Note that labels made following "Data.HList.Labelable" allow+  using "Control.Lens.^." instead.+-}+++(.!.) :: (HasField l r v) => r -> Label l -> v+r .!. l =  hLookupByLabel l r++-- --------------------------------------------------------------------------++-- Delete++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 .-.+{-|+  Remove a field from a record. At the same+  level as other record modification options ('.*.'). Analagous+  to (@\\\\@) in lists.++  > record1 .-. label1++  > label1 .=. value1 .*.+  > label2 .=. value2 .-.+  > label2 .*.+  > emptyRecord++  > label1 .=. value1 .-.+  > label1 .*.+  > label2 .=. value2 .*.+  > emptyRecord++  > record1 .*. label1 .=. record2 .!. label1+  >         .*. label2 .=. record2 .!. label2+  >         .-. label1++-}+(.-.) :: (HDeleteAtLabel r l xs xs') =>+    r xs -> Label l -> r xs'+r .-. l =  hDeleteAtLabel l r+++-- --------------------------------------------------------------------------++-- Update++-- | 'hUpdateAtLabel' @label value record@++class+    HUpdateAtLabel record (l :: k) (v :: *) (r :: [*]) (r' :: [*])+          | l v r -> r', l r' -> v where+    hUpdateAtLabel :: SameLength r r' => Label l -> v -> record r -> record r'++instance (HUpdateAtLabel2 l v r r',+        HasField l (Record r') v) =>+        HUpdateAtLabel Record l v r r' where+    hUpdateAtLabel = hUpdateAtLabel2++{- alternative impl which reports a Fail constraint that is too long (the+one from HUpdateAtHNat) on ghc 7.10 RC1++instance (HasField l (Record r') v,+          HFindLabel l r n,+          HUpdateAtHNat n (Tagged l v) r,+          HUpdateAtHNatR n (Tagged l v) r ~ r',+          SameLength r r') =>+  HUpdateAtLabel Record l v r r' where+  hUpdateAtLabel l v (Record r) =+    Record (hUpdateAtHNat (Proxy::Proxy n) (newLVPair l v) r)+-}++class HUpdateAtLabel2 (l :: k) (v :: *) (r :: [*]) (r' :: [*])+        | l r v -> r' where+    hUpdateAtLabel2 :: Label l -> v -> Record r -> Record r'++class HUpdateAtLabel1 (b :: Bool) (l :: k) (v :: *) (r :: [*]) (r' :: [*])+        | b l v r -> r' where+    hUpdateAtLabel1 :: Proxy b -> Label l -> v -> Record r -> Record r'++instance HUpdateAtLabel1 True l v (Tagged l e ': xs) (Tagged l v ': xs) where+    hUpdateAtLabel1 _b _l v (Record (e `HCons` xs)) = Record (e{ unTagged = v } `HCons` xs)++instance HUpdateAtLabel2 l v xs xs' => HUpdateAtLabel1 False l v (x ': xs) (x ': xs') where+    hUpdateAtLabel1 _b l v (Record (x `HCons` xs)) = case hUpdateAtLabel2 l v (Record xs) of+        Record xs' -> Record (x `HCons` xs')++instance (HEqK l l' b, HUpdateAtLabel1 b l v (Tagged l' e ': xs) xs')+    => HUpdateAtLabel2 l v (Tagged l' e ': xs) xs' where+    hUpdateAtLabel2 = hUpdateAtLabel1 (Proxy :: Proxy b)++-- | XXX+instance Fail (FieldNotFound l ()) => HUpdateAtLabel2 l v '[] '[] where+    hUpdateAtLabel2 _ _ r = r+++infixr 2 .@.+{-|++  Update a field with a particular value.+  Same fixity as (.*.) so that extensions and updates can be chained.+  There is no real list analogue, since there is no Prelude defined+  update.++  > label1 .=. value1 .@. record1++-}+f@(Tagged v) .@. r  =  hUpdateAtLabel (labelLVPair f) v r+++-- --------------------------------------------------------------------------+-- Projection++-- $projection+-- It is also an important operation: the basis of many+-- deconstructors -- so we try to implement it efficiently.+++-- | @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 ls (Record r) = mkRecord (fst $ h2projectByLabels ls r)++-- | See 'H2ProjectByLabels'+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::[*]) 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)++instance H2ProjectByLabels (l ': ls) '[] '[] '[] where+    h2projectByLabels _ _ = (HNil,HNil)++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 [*]) (ls::[*]) r rin rout+                         | b ls r -> rin rout where+    h2projectByLabels' :: Proxy b -> proxy ls ->+                                     HList r -> (HList rin,HList rout)++instance H2ProjectByLabels ls1 r rin rout =>+    H2ProjectByLabels' ('Just ls1) ls (f ': r) (f ': rin) rout where+    h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout)+        where (rin,rout) = h2projectByLabels (Proxy::Proxy ls1) r++-- | if ls above has labels not in the record,+-- we get labels (rin `isSubsetOf` ls).+instance H2ProjectByLabels ls r rin rout =>+    H2ProjectByLabels' 'Nothing ls (f ': r) rin (f ': rout) where+    h2projectByLabels' _ ls (HCons x r) = (rin, HCons x rout)+        where (rin,rout) = h2projectByLabels ls r++-- --------------------------------------------------------------------------+{- | Rename the label of record++>>> hRenameLabel x y (x .=. () .*. emptyRecord)+Record{y=()}++-}+hRenameLabel l l' r = r''+ where+  v   = hLookupByLabel l r+  r'  = hDeleteAtLabel l r+  r'' = newLVPair l' v .*. r'+++-- --------------------------------------------------------------------------++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++{- ^++We could also say:++> hTPupdateAtLabel l v r = hUpdateAtLabel l v r `asTypeOf` r++Then we were taking a dependency on Haskell's type equivalence.+This would also constrain the actual implementation of hUpdateAtLabel.++-}++infixr 2 .<.+{-|+  The same as '.@.', except type preserving. It has the same fixity as (.\@.).++-}+f@(Tagged v) .<. r = hTPupdateAtLabel (labelLVPair f) v r++-- --------------------------------------------------------------------------+-- | Subtyping for records++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 HDeleteLabels ks r r' | ks r -> r'+ where hDeleteLabels :: proxy (ks :: [*]) -- ^ as provided by labelsOf+          -> Record r -> Record 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+++class  HLeftUnion r r' r'' | r r' -> r''+ where hLeftUnion :: Record r -> Record r' -> Record 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+++infixl 1 .<++.+{-|+  Similar to list append, so give this slightly lower fixity than+  (.*.), so we can write:++   > field1 .=. value .*. record1 .<++. record2++-}+(.<++.) ::  (HLeftUnion r r' r'') => Record r -> Record r' -> Record r''+r .<++. r' = hLeftUnion r r'+++-- --------------------------------------------------------------------------+-- $symmetricUnion+-- Compute the symmetric union of two records r1 and r2 and+-- return the pair of records injected into the union (ru1, ru2).+--+-- To be more precise, we compute the symmetric union /type/ @ru@+-- of two record /types/ @r1@ and @r2@. The emphasis on types is important.+--+-- The two records (ru1,ru2) in the result of 'unionSR' have the same+-- type ru, but they are generally different values.+-- Here the simple example: suppose+--+-- >  r1 = (Label .=. True)  .*. emptyRecord+-- >  r2 = (Label .=. False) .*. emptyRecord+--+-- Then 'unionSR' r1 r2 will return (r1,r2). Both components of the result+-- are different records of the same type.+--+--+-- To project from the union ru, use 'hProjectByLabels'.+-- It is possible to project from the union obtaining a record+-- that was not used at all when creating the union.+--+-- We do assure however that if @unionSR r1 r2@ gave @(r1u,r2u)@,+-- then projecting r1u onto the type of r1 gives the /value/ identical+-- to r1. Ditto for r2.++class UnionSymRec r1 r2 ru | r1 r2 -> ru where+    unionSR :: Record r1 -> Record r2 -> (Record ru, Record ru)++instance (r1 ~ r1') => UnionSymRec r1 '[] r1' where+    unionSR r1 _ = (r1, r1)++instance ( HMemberLabel l r1 b+         , UnionSymRec' b r1 (Tagged l v) r2' ru+         )+    => UnionSymRec r1 (Tagged l v ': r2') ru+    where+    unionSR r1 (Record (HCons f r2')) =+        unionSR' (Proxy::Proxy b) r1 f (Record r2')++class UnionSymRec' (b :: Bool) r1 f2 r2' ru | b r1 f2 r2' -> ru where+    unionSR' :: Proxy b -> Record r1 -> f2 -> Record r2'  -> (Record ru, Record ru)++++-- | 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,+          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),+          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'+             ul' = f2 .*. ul+             ur' = f2 .*. ur++-- --------------------------------------------------------------------------+-- | Rearranges a record by labels. Returns the record r, rearranged such that+-- the labels are in the order given by ls. (LabelsOf r) must be a+-- permutation of ls.+hRearrange :: (HLabelSet ls, HRearrange ls r r') => Proxy ls -> Record r -> Record r'+hRearrange ls (Record r) = Record (hRearrange2 ls r)++{- | 'hRearrange'' is 'hRearrange' where ordering specified by the Proxy+argument is determined by the result type.++With built-in haskell records, these @e1@ and @e2@ have the same type:++> data R = R { x, y :: Int }+> e1 = R{ x = 1, y = 2}+> e2 = R{ y = 2, x = 1}++'hRearrange'' can be used to allow either ordering to be accepted:++> h1, h2 :: Record [ Tagged "x" Int, Tagged "y" Int ]+> h1 = hRearrange' $+>     x .=. 1 .*.+>     y .=. 2 .*.+>     emptyRecord+>+> h2 = hRearrange' $+>     y .=. 2 .*.+>     x .=. 1 .*.+>     emptyRecord++-}+hRearrange' r =+    let r' = hRearrange (labelsOf r') r+    in r'+++class Rearranged r s t a b where+    -- @Iso (r s) (r t) (r a) (r b)@+    rearranged :: (Profunctor p, Functor f) => r a `p` f (r b) -> r s `p` f (r t)+++{- | @Iso (Record s) (Record t) (Record a) (Record b)@++where @s@ is a permutation of @a@, @b@ is a permutation of @t@.+In practice 'sameLabels' and 'sameLength' are likely needed on both+sides of @rearranged@, to avoid ambiguous types.++An alternative implementation:++> rearranged x = iso hRearrange' hRearrange' x++-}+instance (la ~ LabelsOf a, lt ~ LabelsOf t,+          HRearrange la s a,+          HRearrange lt b t,+          HLabelSet la,+          HLabelSet lt)+  => Rearranged Record s t a b where+    rearranged = iso (hRearrange (Proxy :: Proxy la))+                     (hRearrange (Proxy :: Proxy lt))++{- | @Iso' (r s) (r a)@++where @s@ is a permutation of @a@ -}+rearranged' x = isSimple rearranged x++-- | Helper class for 'hRearrange'+class (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 (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,+          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 HRearrange4 (l :: *) (ls :: [*]) rin rout r' | l ls rin rout -> r' where+    hRearrange4 :: proxy l -> Proxy ls -> HList rin -> HList rout -> HList r'++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. XXX FieldNotFound+instance Fail (FieldNotFound l ()) =>+        HRearrange4 l ls '[] rout '[] where+   hRearrange4 _ _ _ _ = error "Fail has no instances"++-- | For improved error messages+instance Fail (ExtraField l) =>+          HRearrange3 '[] (Tagged l v ': a) '[] where+   hRearrange3 _ _ = error "Fail has no instances"+++-- --------------------------------------------------------------------------+-- $lens+-- Lens-based setters/getters are popular. hLens packages up+-- 'hUpdateAtLabel' and 'hLookupByLabel'.+--+-- Refer to @examples/lens.hs@ and @examples/labelable.hs@ for examples.++-- | constraints needed to implement 'HLens'+type HLensCxt x r s t a b =+    (HasField x (r s) a,+     HUpdateAtLabel r x b s t,+     HasField x (r t) b,+     HUpdateAtLabel r x a t s,+     SameLength s t,+     SameLabels s t)++class HLensCxt x r s t a b => HLens x r s t a b+        | x s b -> t, x t a -> s, -- need to repeat fundeps implied by HLensCxt+          x s -> a, x t -> b where+    -- | @hLens :: Label x -> Lens (r s) (r t) a b@+    hLens :: Label x -> (forall f. Functor f => (a -> f b) -> (r s -> f (r t)))++instance HLensCxt r x s t a b => HLens r x s t a b where+  hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab))+++{- | map over the values of a record. This is a shortcut for++  > \ f (Record a) -> Record (hMap (HFmap f) a)++[@Example@]++suppose we have a function that should be applied to every element+of a record:++>>> let circSucc_ x | x == maxBound = minBound | otherwise = succ x++>>> :t circSucc_+circSucc_ :: (Bounded a, Enum a, Eq a) => a -> a++Use a shortcut ('Fun') to create a value that has an appropriate 'ApplyAB' instance:++>>> let circSucc = Fun circSucc_ :: Fun '[Eq,Enum,Bounded] '()++Confirm that we got Fun right:++>>> :t applyAB circSucc+applyAB circSucc :: (Bounded b, Enum b, Eq b) => b -> b++>>> applyAB circSucc True+False++define the actual record:++>>> let r = x .=. 'a' .*. y .=. False .*. emptyRecord+>>> r+Record{x='a',y=False}++>>> hMapR circSucc r+Record{x='b',y=True}++-}+hMapR f r = applyAB (HMapR f) r++newtype HMapR f = HMapR f++instance (HMapCxt Record f x y, rx ~ Record x, ry ~ Record y)+      => ApplyAB (HMapR f) rx ry where+        applyAB (HMapR f) = hMapAux f++instance HMapAux HList (HFmap f) x y =>+    HMapAux Record f x y where+      hMapAux f (Record x) = Record (hMapAux (HFmap f) x)++++-- --------------------------------------------------------------------------+-- | This instance allows creating a Record with+--+-- @hBuild 3 'a' :: Record '[Tagged "x" Int, Tagged "y" Char]@+instance (HReverse l lRev,+         HMapTaggedFn lRev l') => HBuild' l (Record l') where+  hBuild' l = hMapTaggedFn (hReverse l)++-- | serves the same purpose as 'hEnd'+hEndR :: Record a -> Record a+hEndR = id+++-- | see 'hEndP'+instance (HRevAppR l '[] ~ lRev,+          HExtendRs lRev (Proxy ('[] :: [*])) ~ Proxy l1,+          l' ~ l1) => HBuild' l (Proxy l') where+  hBuild' _ = Proxy++{- | @'hEndP' $ 'hBuild' label1 label2@++is one way to make a Proxy of labels (for use with 'asLabelsOf'+for example). Another way is++@label1 .*. label2 .*. 'emptyProxy'@++-}+hEndP :: Proxy (xs :: [k]) -> Proxy xs+hEndP = id++type family HExtendRs (ls :: [*]) (z :: k) :: k+type instance HExtendRs (l ': ls) z = HExtendR l (HExtendRs ls z)+type instance HExtendRs '[] z = z++-- --------------------------------------------------------------------------++{- |++>>> let x :: Record '[Tagged "x" Int]; x = undefined+>>> let y :: Record '[Tagged "x" Char]; y = undefined+>>> :t hZip x y+hZip x y :: Record '[Tagged "x" (Int, Char)]++-}+instance (HZipRecord x y xy, SameLengths [x,y,xy])+      => HZip Record x y xy where+    hZip = hZipRecord++instance (HZipRecord x y xy, SameLengths [x,y,xy])+      => HUnzip Record x y xy where+    hUnzip = hUnzipRecord+++#if __GLASGOW_HASKELL__ != 706+{- | Missing from ghc-7.6, because HZip Proxy instances interfere with HZip+HList instances.++a variation on 'hZip' for 'Proxy', where+the list of labels does not have to include Label+(as in @ts'@)++>>> let ts = Proxy :: Proxy ["x","y"]+>>> let ts' = Proxy :: Proxy [Label "x",Label "y"]+>>> let vs = Proxy :: Proxy [Int,Char]++>>> :t zipTagged ts Proxy+zipTagged ts Proxy :: Proxy '[Tagged "x" y, Tagged "y" y1]++>>> :t zipTagged ts vs+zipTagged ts vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]+++And and the case when hZip does the same thing:++>>> :t zipTagged ts' vs+zipTagged ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]++>>> :t hZip ts' vs+hZip ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]++-}+zipTagged :: (MapLabel ts ~ lts,+              HZip Proxy lts vs tvs)+      => Proxy ts -> proxy vs -> Proxy tvs+zipTagged _ _ = Proxy+#endif++++class HZipRecord x y xy | x y -> xy, xy -> x y where+    hZipRecord :: Record x -> Record y -> Record xy+    hUnzipRecord :: Record xy -> (Record x,Record y)+++instance HZipRecord '[] '[] '[] where+    hZipRecord _ _ = emptyRecord+    hUnzipRecord _ = (emptyRecord, emptyRecord)++instance HZipRecord as bs abss+       => HZipRecord (Tagged x a ': as) (Tagged x b ': bs) (Tagged x (a,b) ': abss) where+    hZipRecord (Record (Tagged a `HCons` as)) (Record (Tagged b `HCons` bs)) =+        let Record abss = hZipRecord (Record as) (Record bs)+        in Record (Tagged (a,b) `HCons` abss)+    hUnzipRecord (Record (Tagged (a,b) `HCons` abss)) =+        let (Record as, Record bs) = hUnzipRecord (Record abss)+        in (Record (Tagged a `HCons` as), Record (Tagged b `HCons` bs))+++-- | instead of explicit recursion above, we could define HZipRecord in+-- terms of 'HZipList'. While all types are inferred, this implementation+-- is probably slower, so explicit recursion is used in the 'HZip' 'Record'+-- instance.+hZipRecord2 x y = hMapTaggedFn (hZipList (recordValues x) (recordValues y))+        `asLabelsOf` x `asLabelsOf` y++hUnzipRecord2 xy = let (x,y) = hUnzipList (recordValues xy)+                 in (hMapTaggedFn x `asLabelsOf` xy, hMapTaggedFn y `asLabelsOf` xy)+++{- | similar to 'asTypeOf':++>>> let s0 = Proxy :: Proxy '["x", "y"]+>>> let s1 = Proxy :: Proxy '[Label "x", Label "y"]+>>> let s2 = Proxy :: Proxy '[Tagged "x" Int, Tagged "y" Char]++>>> let f0 r = () where _ = r `asLabelsOf` s0+>>> let f1 r = () where _ = r `asLabelsOf` s1+>>> let f2 r = () where _ = r `asLabelsOf` s2++>>> :t f0+f0 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++>>> :t f1+f1 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++>>> :t f2+f2 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++-}+asLabelsOf :: (HAllTaggedLV x, SameLabels x y, SameLength x y) => r x -> s y -> r x+asLabelsOf = const
− Data/HList/RecordP.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts,-  UndecidableInstances, FlexibleInstances #-}-{-# OPTIONS -fglasgow-exts #-}--{- |-   The HList library--   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Extensible records: labels are phantom, so at run-time, the record-   is just a heterogenous list of field values.--   This sort of record is generalizable to `tables' (which are, at-   run-time, a list or a map containing the heterogenous lists-   of field values).--   The are different models of labels that go with this module;-   see the files Label?.hs.--}--module Data.HList.RecordP where--import Data.HList.FakePrelude-import Data.HList.HListPrelude-import Data.HList.Record-import Data.HList.HArray--{-----------------------------------------------------------------------------}---- Record types as Phantom labels with values--newtype RecordP ls vs = RecordP 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 _ vs = RecordP vs---- The contraint that two HLists have the same length-class HSameLength l1 l2-instance HSameLength HNil HNil-instance HSameLength l1 l2 => HSameLength (HCons e1 l1) (HCons e2 l2)---- Build an empty record-emptyRecordP :: RecordP HNil HNil-emptyRecordP = mkRecordP HNil HNil---- Converting between RecordP and Record (label/value pairs)---- The following class declares a bijection between Record and recordP-class HRLabelSet r => RecordR2P r ls vs | r -> ls vs, ls vs -> r where-    record_r2p :: Record r -> RecordP ls vs-    record_p2r :: RecordP ls vs -> Record r--instance RecordR2P HNil HNil HNil where-    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---{-----------------------------------------------------------------------------}---- A Show instance to appeal to normal records--- to save the coding time (rather than run-time), we just--- convert RecordP to regular Record, which we know how to show--instance (RecordR2P r ls vs, ShowComponents r, HRLabelSet r) =>-    Show (RecordP ls vs) where show rp = show $ record_p2r rp---{-----------------------------------------------------------------------------}---- 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))- where-  hExtend (LVPair v) (RecordP vs) = mkRecordP undefined (HCons v vs)---{-----------------------------------------------------------------------------}---- Record concatenation--instance ( HLabelSet ls''-         , HAppend ls ls' ls''-         , HAppend vs vs' vs''-         , HSameLength ls'' vs''-         )-    => HAppend (RecordP ls vs) (RecordP ls' vs') (RecordP ls'' vs'')- where-  hAppend (RecordP vs) (RecordP vs') = mkRecordP undefined (hAppend vs vs')--{-----------------------------------------------------------------------------}---- Lookup operation---- Because hLookupByLabel is so frequent and important, we--- 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)--class HasFieldP' b l r v | b l r -> v where-    hLookupByLabelP' :: b -> l -> r -> v--instance HasFieldP' HTrue l (RecordP (HCons l ls) (HCons 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-    hLookupByLabelP' _ l (RecordP (HCons _ vs)) =-        hLookupByLabel l ((RecordP vs)::RecordP ls vs)---{-----------------------------------------------------------------------------}---- Delete operation-hDeleteAtLabelP :: HProjectByLabelP l ls vs lso v vso =>-                   l -> RecordP ls vs -> RecordP lso vso-hDeleteAtLabelP l r = snd $ h2ProjectByLabelP l r---{-----------------------------------------------------------------------------}---- Update operation-hUpdateAtLabelP :: (HUpdateAtHNat n e1 t1 l', HFind e t n) => e -> e1 -> RecordP t t1 -> RecordP ls l'-hUpdateAtLabelP l v rp@(RecordP vs) = RecordP (hUpdateAtHNat n v vs)- where-  n       = hFind l (labels_of_recordp rp)--{-----------------------------------------------------------------------------}--- Projection for records--- It is also an important operation: the basis of many--- deconstructors -- so we try to implement it efficiently.---- 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)--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)--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)--instance HProjectByLabelP' HTrue l (HCons l ls) (HCons 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-    h2ProjectByLabelP' _ l (RecordP (HCons v' vs)) =-        let (v,RecordP vso) = h2ProjectByLabelP l ((RecordP vs)::RecordP ls vs)-        in (v, RecordP (HCons v' vso))----- Invariant: r = rin `disjoint-union` rout---            labels(rin) = ls--- classes H2ProjectByLabels and H2ProjectByLabels' are declared in--- Record.hs--instance H2ProjectByLabels (HCons l ls)-                           (RecordP HNil HNil) (RecordP HNil HNil)-                           (RecordP HNil HNil)-    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)--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' _ 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' _ ls (RecordP (HCons v' vs')) =-        (rin, RecordP (HCons v' vo))-        where (rin,RecordP vo) =-                  h2projectByLabels ls ((RecordP vs')::RecordP ls' vs')---{-----------------------------------------------------------------------------}---- Subtyping for records---- Hmm, a bit too conservative. It works for all our examples,--- where the record extension is by simple extension. In the future,--- we should account for possible field permutation.--instance H2ProjectByLabels ls' (RecordP ls vs) (RecordP ls' vs') rout-    =>  SubType (RecordP ls vs) (RecordP ls' vs')
+ Data/HList/RecordPuns.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoPolyKinds #-}+{- | Description : quasiquoter inspired by -XNamedFieldPuns -}+module Data.HList.RecordPuns (+    -- $ex+    pun++    ) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.HList.Record+import Data.HList.FakePrelude+import Data.List+import Data.HList.HList++{- $ex++>>> :set -XQuasiQuotes -XViewPatterns++[@patterns@]++>>> let y = Label :: Label "y"+>>> let x = Label :: Label "x"+>>> [pun| x y |] <- return (x .=. 3 .*. y .=. "hi" .*. emptyRecord)+>>> print (x,y)+(3,"hi")++[@expressions@]++Compare with the standard way to construct records above++>>> let x = 3; y = "hi"+>>> [pun|x y|]+Record{x=3,y="hi"}++[@nesting@]++Nesting is supported. Variables inside+@{ }@ and @( )@ are one level deeper, like the built-in syntax.+Furthermore the outer @{ }@ can be left out because @[pun|{x}|]@ is more+cluttered than @[pun|x|]@.+More concretely the pattern:+++> let [pun| ab@{ a b } y z c{d} |] = x++is short for:++> let ab = x.ab+>     a = x.ab.a+>     b = x.ab.b+>     y = x.y+>     z = x.z+>     -- c is not bound+>     d = x.c.d++Where here `.` is a left-associative field lookup (as it is in other languages).++The pun quasiquoter can also be used in an expression context:++> let mkX ab a b y z d = [pun| ab@{ a b } y z c{d} |]+>     x = mkX ab b y z d++Here `mkX` includes @ab a b y z d@. @ab@ needs to be a record, and if it has+fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ (via+'hLeftUnion' = '.<++.') . In other words,++> let mkX ab_ a b y z d = let ab = [pun| a b |] .<++. ab_+>                               in [pun| ab y z c{d} |]++For patterns, any order and additional fields are allowed if @{ }@ is used,+just as in built-in record syntax. But it is often necessary to restrict the+order and number of fields, such as if the record is a 'hRearrange' of a 'hLeftUnion'.+So use @( )@ instead:++> let [pun| (x _ y{}) |] = list+> -- desugars to something like:+> Record ((Tagged x :: Tagged "x" s1) `HCons`+>         (Tagged _ :: Tagged t   s2) `HCons`+>         (Tagged _ :: Tagged "y" s3) `HCons`+>          HNil) = list++Note that this also introduces the familiar wild card pattern (@_@),+and shows again how to ensure a label is present but not bind a variable+to it.++For comparison, here are three equivalent ways to define variables `x` and `y`++> let [pun| x y{} |] = r+> let [pun|{ x y{} }|] = r -- or this+> let x = r .!. (Label :: Label "x")+>     y = constrainType (r .!. (Label :: Label "y"))+>     constrainType :: Record t -> Record t+>     constrainType = id++See also @examples/pun.hs@. In @{}@ patterns, @pun@ can work with+'Variant' too.++-}+++-- | 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 = 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++-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2),+-- where x1 = Label :: Label "x1"+extracts xs = do+    record <- newName "record"+    -- to fix #5 I could comment out the ensureLength below+    lamE [varP record] $ tupE+            [ [| $(varE record) .!. $label  |]+                | x <- xs,+                let label = [| Label :: Label $(litT (strTyLit x)) |],+                x /= "_"+                ]++mkPair :: String -> ExpQ -> ExpQ+mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |]++++me :: Tree -> ExpQ+me (C as) = foldr (\(l,e) acc -> [| $(mkPair l e) .*. $acc |]) [| emptyRecord |] (mes as)+me (D _as) = error "Data.HList.RecordPuns.mp impossible"+me a = do+    reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a+    me (C [a])++mes :: [Tree] -> [(String, ExpQ)]+mes (V a : V "@": b : c) = (a, [| $(me b) `hLeftUnion` $(dyn a) |]) : mes c+mes (V a : C b : c)      = (a, me (C b)) : mes c+mes (V a : D b : c)      = (a, me (C b)) : mes c+mes (V a : b)            = (a, varE (mkName a)) : mes b+mes [] = []+mes inp = error $ "Data.HList.RecordPuns.mes: cannot translate remaining:" +++                        show (map ppTree inp)++mp :: Tree -> PatQ+mp (C as) =+    let extractPats = mps as+        tupleP = tupP [ p | (binding, p) <- extractPats, binding /= "_" ]+    in viewP (extracts (map fst extractPats)) tupleP+++mp (D as) = conP 'Record+  [foldr ( \ (n,p) xs -> conP 'HCons+                [ let ty+                          | n == "_"  = [| undefined :: Tagged anyLabel t |]+                          | otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |]+                  in viewP [| \x -> x `asTypeOf` $ty |]+                      (conP 'Tagged [p]),+                xs])+          (conP 'HNil [])+          (mps as)]+mp a = do+    reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a+    mp (C [a])++mps :: [Tree] -> [(String, PatQ)]+mps (V a : V "@" : b : c) = (a, asP (mkName a) (mp b)) :  mps c+mps (V a : C b : c) = (a, mp (C b)) : mps c+mps (V a : D b : c) = (a, mp (D b)) : mps c+mps (V "_" : 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:" +++                        show (map ppTree inp)++data Tree = C [Tree] -- ^ curly @{ }@+          | D [Tree] -- ^ @(  )@+          | V String -- ^ variable+  deriving Show++{- |++>>> parseRec "{ a b c {d e f}  } d"+C [C [V "a",V "b",V "c",C [V "d",V "e",V "f"]],V "d"]++>>> ppTree $ parseRec "{a b c {d e {} f @ g}}"+"{a b c {d e {} f @ g}}"++>>> ppTree $ parseRec "a b c {d e {} f @ g}"+"{a b c {d e {} f @ g}}"++>>> ppTree $ parseRec "(a b { (d) e } )"+"(a b {(d) e})"++-}+parseRec :: String -> Tree+parseRec str = case parseRec' 0 0 [[]] $ lexing str of+    [x] -> x -- avoid adding another layer if possible+    x -> C (reverse x)++parseRec' :: Int -> Int -> [[Tree]] -> [String] -> [Tree]+parseRec' n m accum  ("{" : rest)  = parseRec' (n+1) m ([] : accum) rest+parseRec' n m accum  ("(" : rest)  = parseRec'  n (m+1) ([] : accum) rest+parseRec' n m (a:b:c) ("}" : rest) = parseRec' (n-1) m ((C (reverse a) : b) : c)  rest+parseRec' n m (a:b:c) (")" : rest) = parseRec' n (m-1) ((D (reverse a) : b) : c)  rest+parseRec' n m (b:c) (a   : rest)+         | a `notElem` ["{","}","(",")"] = parseRec' n m   ((V a : b) : c) rest+parseRec' 0 0 (a:_) []             = a+parseRec' _ _ accum e              = error ("Data.HList.RecordPuns.parseRec' unexpected: " ++ show e+                                            ++ "\n parsed:" ++ show (reverse accum))++ppTree :: Tree -> String+ppTree (C ts) = "{" ++ unwords (map ppTree ts) ++ "}"+ppTree (D ts) = "(" ++ unwords (map ppTree ts) ++ ")"+ppTree (V x)  = x++lexing = unfoldr (\v -> case lex v of+                    ("", "") : _ -> Nothing+                    e : _ -> Just e+                    _ -> Nothing)
+ Data/HList/RecordU.hs view
@@ -0,0 +1,434 @@+{- | Description: records where elements are stored in unboxed arrays++The public interface is exported from <Data-HList-CommonMain.html#t:RecordU RecordU>++-}+module Data.HList.RecordU where++import Data.Array.Unboxed+import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.HList++import Data.HList.HArray+import LensDefs++import Data.HList.Labelable++import Unsafe.Coerce++-- * Type definitions+-- ** RecordUS++{- | 'RecordUS' is stored as a 'HList' of 'RecordU' +to allow the 'RecordUS' to contain elements of different+types, so long all of the types can be put into an unboxed+array ('UArray').++It is advantageous (at least space-wise) to sort the record to keep+elements with the same types elements adjacent. See 'SortForRecordUS'+for more details.  -}+newtype RecordUS (x :: [*]) =+    RecordUS Any -- ^ Any here is the @HList u@+                 -- given @'RecordUSCxt' x u@++-- | connect the unpacked @x@ representation with the+-- corresponding list of RecordU @u@ representation.+class RecordUSCxt (x :: [*]) (u :: [*]) | x -> u, u -> x where+  {- | @O(1)@ should be possible to implement this without+  unsafeCoerce, but we want to hide the @u@ parameter _and_+  keep the RecordUSCxt as a class (instead of a type+  family) because of 'HEq'. In some cases it is possible+  to have instances that do not actually respect the functional+  dependency, but this should be safe if the check is not+  disabled (by using @-XDysfunctionalDependencies@+  <https://phabricator.haskell.org/D69>, or ghc-7.6) -}+  recordUSToHList :: RecordUS x -> HList u+  recordUSToHList (RecordUS x) = unsafeCoerce x++  -- | @O(1)@ should be possible to implement this without+  -- unsafeCoerce+  hListToRecordUS :: HList u -> RecordUS x+  hListToRecordUS x = RecordUS (unsafeCoerce x)++-- | the only instance+instance (HGroupBy EqTagValue x g, HMapUnboxF g u) => RecordUSCxt x u++data EqTagValue+instance HEqByFn EqTagValue+instance (txv ~ Tagged x v,+          tyw ~ Tagged y w,+          HEq v w b) => HEqBy EqTagValue txv tyw b++-- | proof that @'hMap' 'UnboxF' :: r xs -> r us@ can determine+-- @xs@ from @us@ and @us@ from @xs@+class HMapUnboxF (xs :: [*]) (us :: [*]) | xs -> us, us -> xs+instance HMapUnboxF '[] '[]+instance HMapUnboxF xs us => HMapUnboxF (HList x ': xs) (RecordU x ': us)+++instance (RecordUSCxt x u, Show (HList u)) => Show (RecordUS x) where+    showsPrec n r = ("RecordUS " ++) . showsPrec n (recordUSToHList r)++-- ** RecordU++{- | A type which behaves similarly to 'Record', except+all elements must fit in the same 'UArray'. A consequence of+this is that @RecordU@ has the following properties:++* it is strict in the element types++* it cannot do type-changing updates of 'RecordU', except if+  the function applies to all elements++* it probably is slower to update the very first elements+  of the 'RecordU'++The benefit is that lookups should be faster and records+should take up less space. However benchmarks done with+a slow 'HNat2Integral' do not suggest that RecordU is+faster than Record.+-}+newtype RecordU l = RecordU (UArray Int (GetElemTy l))++type family GetElemTy (x :: [*]) :: *+type instance GetElemTy (Tagged label v ': rest) = v++deriving instance (Show (UArray Int (GetElemTy l))) => Show (RecordU l)+deriving instance (Read (UArray Int (GetElemTy l))) => Read (RecordU l)+deriving instance (Eq  (UArray Int (GetElemTy l))) => Eq  (RecordU l)+deriving instance (Ord (UArray Int (GetElemTy l))) => Ord (RecordU l)++{- | Reorders a 'Record' such that the 'RecordUS' made from it takes up+less space++'Bad' has alternating Double and Int fields++>>> bad+Record{x=1.0,i=2,y=3.0,j=4}++4 arrays containing one element each are needed when this+Record is stored as a RecordUS++>>> recordToRecordUS bad+RecordUS H[RecordU (array (0,0) [(0,1.0)]),RecordU (array (0,0) [(0,2)]),RecordU (array (0,0) [(0,3.0)]),RecordU (array (0,0) [(0,4)])]++It is possible to sort the record++>>> sortForRecordUS bad+Record{x=1.0,y=3.0,i=2,j=4}++This allows the same content to be stored in+two unboxed arrays++>>> recordToRecordUS (sortForRecordUS bad)+RecordUS H[RecordU (array (0,1) [(0,1.0),(1,3.0)]),RecordU (array (0,1) [(0,2),(1,4)])]++-}+class SortForRecordUS x x' | x -> x' where+    sortForRecordUS :: Record x -> Record x'++instance SortForRecordUS '[] '[] where+    sortForRecordUS = id++instance (HPartitionEq EqTagValue x (x ': xs) xi xo,+          SortForRecordUS xo xo',+          sorted ~ HAppendListR xi xo',+          HAppendList xi xo') =>+  SortForRecordUS (x ': xs) sorted where+  sortForRecordUS (Record xs) = Record (hAppendList xi xo')+    where+      f  = Proxy :: Proxy EqTagValue+      x1 = Proxy :: Proxy x+      (xi,xo) = hPartitionEq f x1 xs+      Record xo' = sortForRecordUS (Record xo)++-------------------------------------------------------------- +-- * Lookup++-- | works expected. See examples attached to 'bad'.+instance (HFindLabel l r n,+          HLookupByHNatUS n u (Tagged l v),+          HasField l (Record r) v,+          RecordUSCxt r u) =>+  HasField l (RecordUS r) v where+  hLookupByLabel _ u = case hLookupByHNatUS n (recordUSToHList u) of Tagged v -> v+    where n = Proxy :: Proxy n++class HLookupByHNatUS (n :: HNat) (us :: [*]) (e :: *) | n us -> e where+  hLookupByHNatUS :: Proxy n -> HList us -> e++class HLookupByHNatUS1 (r :: Either HNat HNat) (n :: HNat) (u :: [*]) (us :: [*]) (e :: *)+        | r n u us -> e where+  hLookupByHNatUS1 :: Proxy r -> Proxy n -> RecordU u -> HList us -> e++instance (r ~ HSubtract (HLength u) n,+          RecordU u ~ ru,+          HLookupByHNatUS1 r n u us e) =>+  HLookupByHNatUS n (ru ': us) e where+  hLookupByHNatUS n (HCons u us) = hLookupByHNatUS1 (Proxy :: Proxy r) n u us++instance (HNat2Integral n,+         HLookupByHNatR n u ~ le,+         le ~ Tagged l e,+         IArray UArray e,+         e ~ GetElemTy u) => HLookupByHNatUS1 (Left t) n u us le where+  hLookupByHNatUS1 _ n (RecordU u) _us = Tagged (u ! hNat2Integral n)++instance HLookupByHNatUS t us e => HLookupByHNatUS1 (Right t) n u us e where+  hLookupByHNatUS1 _ _ _ = hLookupByHNatUS (Proxy :: Proxy t)++-- | @HSubtract a b@ is @Left (a-b)@, @Right (b-a)@ or @Right HZero@+type family HSubtract (n1 :: HNat) (n2 :: HNat) :: Either HNat HNat++type instance HSubtract HZero HZero = Right HZero+type instance HSubtract (HSucc x) (HSucc y) = HSubtract x y+type instance HSubtract HZero (HSucc y) = Right (HSucc y)+type instance HSubtract (HSucc y) HZero = Left (HSucc y)+++++-------------------------------------------------------------- +-- * Conversion of RecordUS++-- ** with the actual representation++-- | @Iso (HList s) (HList t) (RecordUS a) (RecordUS b)@+recordUS r = iso hListToRecordUS recordUSToHList r++{- | @Iso (HList s) (RecordUS a)@++@s@ is a HList of 'RecordU' while @a :: [*]@+is list of @Tagged label value@++-}+recordUS' r = isSimple recordUS r++-- ** with 'Record'++-- | @view unboxedS@ or @^. unboxedS@ are preferred+recordToRecordUS :: forall x g u.+   (HMapCxt HList UnboxF g u,+    HMapUnboxF g u,+    HGroupBy EqTagValue x g,+    RecordUSCxt x u)+   => Record x -> RecordUS x+recordToRecordUS (Record x) = hListToRecordUS u+  where+    u :: HList u+    u = hMap UnboxF g ++    g :: HList g+    g = hGroupBy (Proxy :: Proxy EqTagValue) x++-- | @^. from unboxedS@ is preferred+recordUSToRecord :: forall u g x.+  (HConcatFD g x,+   HMapCxt HList BoxF u g,+   HMapUnboxF g u,+   RecordUSCxt x u+  ) => RecordUS x -> Record x+recordUSToRecord rus = Record (hConcatFD g)+  where+    g :: HList g+    g = hMap BoxF (recordUSToHList rus)++-- | @Iso (Record x) (Record y) (RecordUS x) (RecordUS y)@+unboxedS r = iso recordToRecordUS recordUSToRecord r++-- | @Iso' (Record x) (RecordUS x)@+unboxedS' r = isSimple unboxedS r++++-- | all elements of the list have the same type+class ElemTyEq (xs :: [*])++instance + (t1v ~ Tagged t1 v,+  t2v ~ Tagged t2 v,  +  ElemTyEq (tv2 ': rest)) =>+  ElemTyEq (tv1 ': tv2 ': rest)++instance t1v ~ Tagged t v => ElemTyEq (t1v ': rest)+instance ElemTyEq '[]+++instance (IArray UArray v,+          v ~ GetElemTy ls,+          HFindLabel l ls n,+          HNat2Integral n)+    => HasField l (RecordU ls) v where+  hLookupByLabel _ (RecordU ls) = ls ! hNat2Integral (Proxy :: Proxy n)+++instance (r ~ r',+          v ~ GetElemTy r,+          HFindLabel l r n,+          HNat2Integral n,+          IArray UArray v,+          HasField l (Record r') v)+    => HUpdateAtLabel RecordU l v r r' where+  hUpdateAtLabel _ v (RecordU r) = RecordU (r // [(hNat2Integral (Proxy :: Proxy n), v)])+++{- | analogous flip '//'. Similar to '.<++.', except it is restricted+to cases where the left argument holds a subset of elements.++-}+class HUpdateMany lv rx where+    hUpdateMany :: Record lv -> rx -> rx++instance (RecordValues lv,+          HList2List (RecordValuesR lv) v,+          HFindMany (LabelsOf lv) (LabelsOf r) ixs,+          IArray UArray v,+          v ~ GetElemTy r,+          HNats2Integrals ixs) =>+  HUpdateMany lv (RecordU r) where+  hUpdateMany lv (RecordU r) = RecordU (r // (zip ixs (hList2List (recordValues lv))))+     where ixs = hNats2Integrals (Proxy :: Proxy ixs)++-- | implementation in terms of '.<++.'+instance (HLeftUnion lv x lvx,+          HRLabelSet x,+          HLabelSet (LabelsOf x),+          HRearrange (LabelsOf x) lvx x)+  => HUpdateMany lv (Record x) where+    hUpdateMany lv x = hRearrange' (lv .<++. x)++-- | behaves like @map 'HFind'@+class HFindMany (ls :: [k]) (r :: [k]) (ns :: [HNat]) | ls r  -> ns+instance (HFind l r n,+          HFindMany ls r ns) => HFindMany (l ': ls) r (n ': ns)++instance HFindMany '[] r '[]++instance (ApplyAB f (GetElemTy x) (GetElemTy y),+          IArray UArray (GetElemTy y),+          IArray UArray (GetElemTy x)) => HMapAux RecordU f x y where+    hMapAux f (RecordU x) = RecordU (amap (applyAB f) x)++-- | 'hMap' specialized to 'RecordU'+hMapRU :: HMapCxt RecordU f x y => f -> RecordU x -> RecordU y+hMapRU f = hMap f+++-- | @Iso (Record x) (Record y) (RecordU x) (RecordU y)@+unboxed :: forall x y f p.+  (Profunctor p,+   Functor f,+   RecordToRecordU x,+   RecordUToRecord y)+  => RecordU x `p` f (RecordU y)+  -> Record x `p` f (Record y)+unboxed r = iso recordToRecordU recordUToRecord r++-- | @Iso' (Record x) (RecordU x)@+unboxed' x = isSimple unboxed x+++class RecordToRecordU x where+    recordToRecordU :: Record x -> RecordU x++instance (+    RecordValues x,+    HList2List (RecordValuesR x) (GetElemTy x),+    HNat2Integral n,+    HLengthEq x n,+    IArray UArray (GetElemTy x)+   ) => RecordToRecordU x where+  recordToRecordU (rx@(Record x)) = RecordU $ listArray+          (0, hNat2Integral (hLength x) - 1)+          (hList2List (recordValues rx))+ +class RecordUToRecord x where+    recordUToRecord :: RecordU x -> Record x++instance (+    HMapCxt HList TaggedFn (RecordValuesR x) x,+    IArray UArray (GetElemTy x),+    HList2List (RecordValuesR x) (GetElemTy x) +  ) => RecordUToRecord x where+  recordUToRecord (RecordU b) = case list2HList $ elems b of+          Nothing -> error "Data.HList.RecordU.recordUToRecord impossibly too few elements"+          Just y0 -> Record $ hMap TaggedFn (y0 :: HList (RecordValuesR x))++++-- * definitions for doctest examples+type Bad =+         [Tagged "x" Double,+          Tagged "i" Int,+          Tagged "y" Double,+          Tagged "j" Int]++{- | HasField instances++[@RecordUS@]++>>> let r = recordToRecordUS (sortForRecordUS bad)+>>> let s = recordToRecordUS bad++>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let i = Label :: Label "i"+>>> let j = Label :: Label "j"++>>> (r .!. x, r .!. i, r .!. y, r .!. j)+(1.0,2,3.0,4)++>>> (s .!. x, s .!. i, s .!. y, s .!. j)+(1.0,2,3.0,4)+++[@RecordU@]++>>> let t = recordToRecordU bad1+>>> (t .!. x, t .!. y)+(1.0,2.0)++>>> hUpdateAtLabel x 3 t .!. x+3.0++-}+bad :: Record Bad+bad = Tagged 1 .*. Tagged 2 .*. Tagged 3 .*. Tagged 4 .*. emptyRecord++bad1 :: Record [Tagged "x" Double, Tagged "y" Double]+bad1 = Tagged 1 .*. Tagged 2 .*. emptyRecord++-- * Implementation Details++data UnboxF = UnboxF+instance (hx ~ HList x, ux ~ RecordU x,+          RecordToRecordU x) =>+  ApplyAB UnboxF hx ux where+  applyAB _ = recordToRecordU . Record++data BoxF = BoxF++instance (ux ~ RecordU x,+         hx ~ HList x,+         RecordUToRecord x) =>+  ApplyAB BoxF ux hx where+  applyAB _ ux = case recordUToRecord ux of Record hx -> hx+++-- | make a @Lens' (RecordU s) a@+instance (s ~ t, a ~ b,+          IArray UArray a, a ~ GetElemTy s,+          HLensCxt x RecordU s t a b)+        => Labelable x RecordU s t a b where+            type LabelableTy RecordU = LabelableLens+            hLens' x = hLens x++{- TODO+instance Labelable x RecordUS to p f s t a b where+instance (r ~ r', HasField l (Record r) v)+      => HUpdateAtLabel RecordUS l v r r' where+  hUpdateAtLabel = error "recordus hupdateatlabel"++Benchmarks+-}
Data/HList/TIC.hs view
@@ -1,74 +1,203 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# 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.HOccurs-import Data.HList.TIP +import Data.HList.Record+import Data.HList.Variant+import Data.HList.HList -{-----------------------------------------------------------------------------}+import Data.HList.HArray --- | A datatype for type-indexed co-products+import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif+import Text.ParserCombinators.ReadP+import LensDefs -data TIC l = TIC Dynamic+-- --------------------------------------------------------------------------+-- | 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 (Variant l) -{-----------------------------------------------------------------------------}+deriving instance Eq (Variant l) => Eq (TIC l)+deriving instance Ord (Variant l) => Ord (TIC l)+deriving instance Ix (Variant l) => Ix (TIC l)+deriving instance Bounded (Variant l) => Bounded (TIC l)+deriving instance Enum (Variant l) => Enum (TIC l)+deriving instance Monoid (Variant l) => Monoid (TIC l)+deriving instance Semigroup (Variant l) => Semigroup (TIC l) --- | Public constructor -mkTIC :: ( HTypeIndexed l-         , HTypeProxied l-         , HOccurs (Proxy i) l-         , Typeable i-         )-      => i -> TIC l+instance HMapAux Variant f xs ys => HMapAux TIC f xs ys where+    hMapAux f (TIC a) = TIC (hMapAux f a) -mkTIC i = TIC (toDyn i)+-- | @Iso (TIC s) (TIC t) (Variant s) (Variant t)@+--+-- 'typeIndexed' may be more appropriate+ticVariant x = isoNewtype (\(TIC a) -> a) TIC x +-- | @Iso' (TIC s) (Variant s)@+ticVariant' x = isSimple ticVariant x -{-----------------------------------------------------------------------------} --- | Public destructor+-- -------------------------------------------------------------------------- -unTIC :: ( HTypeIndexed l-         , HTypeProxied l-         , HOccurs (Proxy o) l-         , Typeable o+{- | Conversion between type indexed collections ('TIC' and 'TIP')+and the corresponding collection that has other label types ('Variant'+and 'Record' respectively)++See 'typeIndexed''++-}+class TypeIndexed r tr | r -> tr, tr -> r where+    -- | @Iso (r s) (r t) (tr a) (tr b)@+    typeIndexed :: forall p f s t a b.+       (TypeIndexedCxt s t a b, Profunctor p, Functor f) =>+      p (tr (TagR a)) (f (tr (TagR b))) -> p (r s) (f (r t))++type TypeIndexedCxt s t a b =+ (HMapCxt HList TaggedFn b t,+  RecordValues s, RecordValues t,+  a ~ RecordValuesR s,+  b ~ RecordValuesR t,+  SameLabels s t,+  SameLength s t,+  SameLength b a,+  {- to use castVariant instead of unsafeCastVariant+  RecordValuesR (TagR a) ~ a,+  RecordValuesR (TagR b) ~ b,+  SameLength (TagR a) s,+  SameLength (TagR b) t,+  -}+  Coercible (TagR b) t,+  Coercible (TagR a) s,+  HAllTaggedLV s,+  HRLabelSet t,+  TagUntag a,+  TagUntag b)++instance TypeIndexed Record TIP where+    typeIndexed = sameLength . unlabeled . fromTipHList+      where fromTipHList = iso (TIP . hTagSelf) (\(TIP a) -> hUntagSelf a)++instance TypeIndexed Variant TIC where+    typeIndexed = isoNewtype unsafeCastVariant unsafeCastVariant+                . isoNewtype TIC (\(TIC a) -> a)++{- |++@'Iso'' ('Variant' s) ('TIC' a)@++@'Iso'' ('Record' s) ('TIP' a)@++where @s@ has a type like @'[Tagged \"x\" Int]@, and+@a@ has a type like @'[Tagged Int Int]@.+-}+typeIndexed' x = isSimple typeIndexed x++-- --------------------------------------------------------------------------+-- | Public constructor (or, open union's injection function)++mkTIC' :: forall i l proxy.+         ( HTypeIndexed l+         , MkVariant i i l          )-      => TIC l -> Maybe o+      => 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 -unTIC (TIC i) = fromDynamic 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 --- | A type-indexed type sequence that is a sequence of proxy types -class HTypeProxied l-instance HTypeProxied HNil-instance HTypeProxied l => HTypeProxied (HCons (Proxy e) l)+-- --------------------------------------------------------------------------+-- | 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  -{-----------------------------------------------------------------------------}+instance (HasField o (TIC l) mo, mo ~ Maybe o) => HOccurs mo (TIC l) where+    hOccurs = hLookupByLabel (Label :: Label o) --- | TICs are opaque -instance Show (TIC l)+-- | 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 not opaque++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,6 +1,4 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances,-    FlexibleContexts #-}+{-# LANGUAGE CPP #-}  {- |    The HList library@@ -8,252 +6,555 @@    (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.FakePrelude import Data.HList.HListPrelude-import Data.HList.HArray-import Data.HList.HOccurs-import Data.HList.HTypeIndexed+import Data.HList.FakePrelude+import Data.HList.HList+import Data.HList.Record+import Data.HList.HTypeIndexed ()+import Data.HList.TIPtuple+import Data.List (intercalate)+import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif +#if __GLASGOW_HASKELL__ > 710+import Data.Coerce+#endif -{-----------------------------------------------------------------------------}+import LensDefs --- | The newtype for type-indexed products+-- --------------------------------------------------------------------------+-- * The newtype for type-indexed products -newtype TIP l = TIP l-        deriving (Read,Show)+-- | 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} -mkTIP :: HTypeIndexed l => l -> TIP l-mkTIP = TIP+deriving instance Semigroup (HList a) => Semigroup (TIP a)+deriving instance Monoid (HList a) => Monoid (TIP a)+deriving instance Eq (HList a) => Eq (TIP a)+deriving instance (Ord (HList r)) => Ord (TIP r)+deriving instance (Ix (HList r)) => Ix (TIP r)+deriving instance (Bounded (HList r)) => Bounded (TIP r) -unTIP :: TIP l -> l-unTIP (TIP l) = l -emptyTIP :: TIP HNil+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++emptyTIP :: TIP '[] emptyTIP = mkTIP HNil +-- --------------------------------------------------------------------------+-- * Type-indexed type sequences +-- | 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 --- | Type-indexed type sequences+class HAllTaggedEq (l :: [*])+instance HAllTaggedEq '[]+instance (HAllTaggedEq l, tee ~ Tagged e e') => HAllTaggedEq (tee ': l) -class HList l => HTypeIndexed l-instance HTypeIndexed HNil-instance (HOccursNot e l,HTypeIndexed l) => HTypeIndexed (HCons e l)+-- --------------------------------------------------------------------------+-- Implementing the HListPrelude interface +instance (HRLabelSet (Tagged e e ': l), HTypeIndexed l) => HExtend e (TIP l)+ where+  type HExtendR e (TIP l) = TIP (Tagged e e ': l)+  e .*. TIP l = mkTIP (HCons (Tagged e) l) -{-----------------------------------------------------------------------------} ------ One occurrence and nothing is left++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. -- That is, the result type is unified with the element in the list. -- Hence the explicit provision of a result type can be omitted. -- -instance TypeCast e' e => HOccurs e (TIP (HCons e' HNil))- where-  hOccurs (TIP (HCons e' _)) = typeCast e'+instance (tee ~ Tagged e e) => HOccurs e (TIP '[tee]) where+  hOccurs (TIP (HCons (Tagged e) _)) = e -instance HOccurs e (HCons x (HCons y l))-      => HOccurs e (TIP (HCons x (HCons y l)))+instance HasField e (Record (x ': y ': l)) e+      => HOccurs e (TIP (x ': y ': l)) where+  hOccurs (TIP l) = Record l .!. (Label :: Label e)+++instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendListR l l'))+           => HAppend (TIP l) (TIP l')  where-  hOccurs (TIP l) = hOccurs l+  hAppend (TIP l) (TIP l') = mkTIP (hAppend l l') +type instance HAppendR (TIP l) (TIP l') = TIP (HAppendListR l l') -{-----------------------------------------------------------------------------} --- HOccursNot lifted to TIPs+-- instance HOccurrence HList e l l' => HOccurrence TIP e l l'+--  where+--   hOccurrence e = TIP . hOccurrence e . unTIP -instance HOccursNot e l => HOccursNot e (TIP l)+-- --------------------------------------------------------------------------+-- * Shielding type-indexed operations+-- $note The absence of signatures is deliberate! They all must be inferred. +onRecord f (TIP l) = let Record l' = f (Record l) in mkTIP l' -{-----------------------------------------------------------------------------}+instance (HDeleteAtLabel Record e v v',+          HTypeIndexed v')+      => HDeleteAtLabel TIP e v v' where+  hDeleteAtLabel e v = onRecord (hDeleteAtLabel e) v --- | Type-indexed extension------ signature is inferred------ > hExtend' :: (HTypeIndexed t, HOccursNot e t) => e -> TIP t -> TIP (HCons e t)-hExtend' e (TIP l) = mkTIP (HCons e l) -{- $example+tipyUpdate  e t  = hTPupdateAtLabel (fromValue e) e t+  where fromValue :: e -> Label e+        fromValue _ = Label -Valid type I+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 -hExtend' :: (HTypeIndexed l, HOccursNot e l)-         => e -> TIP l -> TIP (HCons e l) -Valid type II+-- | Use 'Labels' to specify the first argument+tipyProject ps t = onRecord (hProjectByLabels ps) t -*TIP> :t hExtend'-hExtend' :: forall l e.-            (HTypeIndexed (HCons e l)) =>-            e -> TIP l -> TIP (HCons e l)+-- | provides a @Lens' (TIP s) a@. 'hLens'' @:: Label a -> Lens' (TIP s) a@+-- is another option.+#if __GLASGOW_HASKELL__ < 707+tipyLens' x = isSimple tipyLens x -- rejected by GHC-7.10RC1+#else+tipyLens' f s = isSimple (hLens x) f (asTIP s) -- rejected by GHC-7.6.3+  where+    x = getA f+    getA :: (a -> f a) -> Label a+    getA _ = Label +    asTIP :: TIP a -> TIP a+    asTIP = id+#endif++{- | provides a @Lens (TIP s) (TIP t) a b@++When using @set@ (also known as @.~@), 'tipyLens'' can address the+ambiguity as to which field \"a\" should actually be updated.+ -}+tipyLens f (TIP s) =+      case hSplitAt (getN s f) (ghc8fix1 s) of+          (x, ta@(Tagged a) `HCons` ys)+             | () <- ghc8fix2 ta ->+              let mkt b = mkTIP (x `hAppendList` (tagSelf b `HCons` ys))+              in mkt <$> f a+  where+    getN :: HFind (Label a) (LabelsOf s) n => HList s -> (a -> f b) -> Proxy n+    getN _ _ = Proxy +    -- without these, tipyLens has a type that has kind variables,+    -- (that end up being * when an actual TIP is provided), leading to+    -- a Properties.LengthIndependent compile error:+    -- .../.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/Data/HList/TIP.hi+    -- Declaration for tipyLens:+    --   Iface type variable out of scope:  k+    -- Cannot continue after interface file error+    ghc8fix1 :: HList (Tagged x x ': xs) -> HList (Tagged x x ': xs)+    ghc8fix1 = id -{-----------------------------------------------------------------------------}+    ghc8fix2 :: Tagged a a -> ()+    ghc8fix2 _ = () --- Lift extension through HExtend -instance ( HOccursNot e l-         , HTypeIndexed l-         )-      => HExtend e (TIP l) (TIP (HCons e l))++-- | The same as 'tipyProject', except also return the+-- types not requested in the @proxy@ argument+tipyProject2 ps (TIP l) = (mkTIP l',mkTIP l'')  where-  hExtend = hExtend'+  (l',l'') = h2projectByLabels ps l  -{-----------------------------------------------------------------------------}+-- -------------------------------------------------------------------------- --- Lifting previous operations+-- | Subtyping for TIPs +instance SubType (TIP l) (TIP '[])+instance (HOccurs e (TIP l1), SubType (TIP l1) (TIP l2))+      =>  SubType (TIP l1) (TIP (e ': l2)) -instance ( HAppend l l' l''-         , HTypeIndexed l''-         )-           => HAppend (TIP l) (TIP l') (TIP l'')- where-  hAppend (TIP l) (TIP l') = mkTIP (hAppend l l') +-- --------------------------------------------------------------------------+-- * conversion to and from 'HList' -instance HOccursMany e l-      => HOccursMany e (TIP l)- where-  hOccursMany = hOccursMany . unTIP+{- | 'TagR' can also be used to avoid redundancy when defining types for TIC and TIP. +>  type XShort = TagR [A,B,C,D] -instance HOccursMany1 e l-      => HOccursMany1 e (TIP l)- where-  hOccursMany1 = hOccursMany1 . unTIP+>  type XLong = [Tagged A A, Tagged B B, Tagged C C, Tagged D D]  -instance HOccursFst e l-      => HOccursFst e (TIP l)- where-  hOccursFst = hOccursFst . unTIP+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: -instance HOccursOpt e l-      => HOccursOpt e (TIP l)- where-  hOccursOpt = hOccursOpt . unTIP+@+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 --- | Shielding type-indexed operations--- The absence of signatures is deliberate! They all must be inferred.+type family UntagR (xs :: [*]) :: [*]+type instance UntagR '[] = '[]+type instance UntagR (x ': xs) = Untag1 x ': UntagR xs+@ -onTIP f (TIP l) = mkTIP (f l)+Length information should flow backwards -tipyDelete  p t  = onTIP (hDeleteAtProxy p) t-tipyUpdate  e t  = onTIP (hUpdateAtType e) t-tipyProject ps t = onTIP (hProjectByProxies ps) t+>>> 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 --- Split produces two TIPs-tipySplit ps (TIP l) = (mkTIP l',mkTIP l'')- where-  (l',l'') = hSplitByProxies ps l+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) --- Subtyping for TIPs+-- | Sometimes the type variables available have @TagR@ already applied+-- (ie the lists have elements like @Tagged X X@). Then this abbreviation+-- is useful:+type UntagTag xs = (TagR (UntagR xs) ~ xs, TagUntagFD (UntagR xs) xs) -instance SubType (TIP l) (TIP HNil)-instance (HOccurs e l, SubType (TIP l) (TIP l'))-      =>  SubType (TIP l) (TIP (HCons e l'))+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 --- * Sample code+type family Untag1 (x :: *) :: *+type instance Untag1 (Tagged k x) = x -{- $sampleCode -Assume+-- | @Iso (TIP (TagR a)) (TIP (TagR b)) (HList a) (HList b)@+tipHList x = iso (\(TIP a) -> hUntagSelf a) (TIP . hTagSelf) x -> myTipyCow = TIP myAnimal+-- | @Iso' (TIP (TagR s)) (HList a)@+tipHList' x = isSimple tipHList x -> animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key-> animalKey = hOccurs -Session log+-- * conversion to and from 'Record' -> *TIP> :t myTipyCow-> myTipyCow :: TIP Animal+-- | @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 -> *TIP> hOccurs myTipyCow :: Breed-> Cow+-- | @Iso' (TIP (TagR s)) (Record a)@+tipRecord' x = isSimple tipRecord x -> *TIP> hExtend BSE myTipyCow-> TIP (HCons BSE->     (HCons (Key 42)->     (HCons (Name "Angus")->     (HCons Cow->     (HCons (Price 75.5)->      HNil)))))+-- --------------------------------------------------------------------------+-- * Zip -> *TIP> BSE .*. myTipyCow-> --- same as before ---+#if __GLASGOW_HASKELL__ < 800+-- pre-coerce+instance (HZipList (UntagR x) (UntagR y) (UntagR xy),+          UntagTag x, UntagTag y, UntagTag xy,+          SameLengths [x,y,xy],+          HTypeIndexed x, HTypeIndexed y,+          HUnzip TIP x y xy+          -- HTypeIndexed xy is always satisfied given the above+          -- constraints (with a handwaving proof), so don't require+          -- callers of hZip/hUnzip to supply such proof+    ) => HZip TIP x y xy where+  hZip = hZipTIP -> *TIP> Sheep .*. myTipyCow-> Type error ... -> *TIP> Sheep .*. tipyDelete myTipyCow (HProxy::HProxy Breed)->TIP (HCons Sheep (HCons (Key 42) (HCons (Name "Angus") (HCons (Price 75.5) HNil))))+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 -> *TIP> tipyUpdate myTipyCow Sheep-> TIP (HCons (Key 42) (HCons (Name "Angus") (HCons Sheep (HCons (Price 75.5) HNil))))+#else+-- ghc-7.10.3 has coerce, but rejects these instances+instance (HZipList xL yL xyL,+          lty ~ (HList xyL -> (HList xL,HList yL)),+          Coercible lty (TIP xy -> (TIP x, TIP y)),+          UntagR x ~ xL, TagR xL ~ x, -- `TagR (UntagR x) ~ x` included by UntagTag+          UntagR y ~ yL, TagR yL ~ y,+          UntagR xy ~ xyL, TagR xyL ~ xy,+          SameLengths '[x,y,xy],+          UntagTag x, UntagTag y, UntagTag xy+        ) => HUnzip TIP x y xy where+  hUnzip = coerce (hUnzipList :: lty) +instance (HUnzip TIP x y xy,+          HZipList xL yL xyL,+          lty ~ (HList xL -> HList yL -> HList xyL),+          Coercible lty (TIP x -> TIP y -> TIP xy) ,+          UntagR x ~ xL,+          UntagR y ~ yL,+          UntagR xy ~ xyL,+          UntagTag x, UntagTag y, UntagTag xy+        ) => HZip TIP x y xy where+  hZip = coerce (hZipList :: lty)+#endif++-- | specialization of 'hZip'+hZipTIP (TIP x) (TIP y) = TIP (hTagSelf (hZipList (hUntagSelf x) (hUntagSelf y)))++-- | specialization of 'hUnzip'+hUnzipTIP (TIP xy) = case hUnzipList (hUntagSelf xy) of+  (x,y) -> (mkTIP (hTagSelf x), mkTIP (hTagSelf y))++++-- --------------------------------------------------------------------------+-- * TIP Transform++{- |++Transforming a TIP: applying to a TIP a (polyvariadic) function+that takes arguments from a TIP and updates the TIP with the result.++In more detail: we have a typed-indexed collection TIP and we+would like to apply a transformation function to it, whose argument+types and the result type are all in the TIP. The function should locate+its arguments based on their types, and update the TIP+with the result. The function may have any number of arguments,+including zero; the order of arguments should not matter.++The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+<http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html>+The problem is an interesting variation of the keyword argument problem.++Examples can be found in @examples/TIPTransform.hs@ and @examples/TIPTransformM.hs@ -} -{-----------------------------------------------------------------------------}+class TransTIP op db where+    ttip :: op -> TIP db -> TIP db --- * Sample 2+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) --- |--- This example from the TIR paper challenges singleton lists.--- Thanks to the HW 2004 reviewer who pointed out the value of this example.--- We note that the explicit type below is richer than the inferred type.--- This richer type is needed for making this operation more polymorphic.--- That is, /a)/ would not work without the explicit type, while it would:------ >  a)  ((+) (1::Int)) $ snd $ tuple oneTrue--- >  b)  ((+) (1::Int)) $ fst $ tuple oneTrue+class TransTIP1 (b :: Bool) (n :: HNat) op db where+    ttip1 :: Proxy b -> Proxy n -> op -> TIP db -> TIP db -tuple :: ( HOccurs e1 (TIP l)-         , HType2HNat e1 l n-         , HDeleteAtHNat n l l'-         , HOccurs e2 (TIP l')-         , HOccurs e2 (TIP l)-         , HType2HNat e2 l n'-         , HDeleteAtHNat n' l l''-         , HOccurs e1 (TIP l'')-         ) =>-              TIP l -> (e1, e2)+-- 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 -tuple (TIP l) = let-                 x  = hOccurs (TIP l)-                 l' = hDeleteAtProxy (toProxy x) l-                 y  = hOccurs (TIP l')-                in (x,y)+-- If op is not found in a TIP, it must be a function. Try to look up+-- its argument in a TIP and recur.+instance (HMember (Tagged arg arg) db b,+          TransTIP2 b arg op db)+    => TransTIP1 False (HSucc n) (arg -> op) db where+    ttip1 _ _ = ttip2 (Proxy :: Proxy b) +instance Fail (FieldNotFound notfun (TIP db))+      => TransTIP1 False HZero notfun db where+    ttip1 = error "TransTIP1 Fail failed" --- | A specific tuple-oneTrue :: TIP (HCons Int (HCons Bool HNil))-oneTrue = hExtend (1::Int) (hExtend True emptyTIP)+class TransTIP2 (b :: Bool) arg op db where+    ttip2 :: Proxy b -> (arg -> op) -> TIP db -> TIP db +instance (HOccurs arg (TIP db),+         TransTIP op db)+   => TransTIP2 True arg op db where+    ttip2 _ f db = ttip (f (hOccurs db)) db -{-----------------------------------------------------------------------------}+instance Fail (FieldNotFound arg (TIP db))+    => TransTIP2 False arg op db where+    ttip2 = error "TransTIP2 Fail failed"++-- ** Monadic version++{- |++In March 2010, Andrew Frank extended the problem for monadic operations.+This is the monadic version of @TIPTransform.hs@ in the present directory.++This is the TF implementation. When specifying the operation to perform over+a TIP, we can leave it polymorphic over the monad. The type checker+will instantiate the monad based on the context.++-}+class Monad m => TransTIPM m op db where+    ttipM :: op -> TIP db -> m (TIP db)++-- Check to see if the operation is a computation whose result+-- is in the TIP. The type variable m' of the kind *->* below+-- can be instantiated either to a monad type constructor, or (arg->).+instance (Monad m, HMember (Tagged op op) db b,+           Arity (m' op) n,+           TransTIPM1 b n m (m' op) db)+    => TransTIPM m (m' op) db where+    ttipM = ttipM1 (Proxy :: Proxy b) (Proxy :: Proxy n)++class Monad m => TransTIPM1 (b :: Bool) (n :: HNat) m op db where+    ttipM1 :: Proxy b -> Proxy n -> op -> TIP db -> m (TIP db)++-- If op is found in a TIP, update the TIP with op.+-- The type variable m' must be equal to the type of the monad+-- in which the final result is reported.+instance (Monad m, m ~ m', HTPupdateAtLabel TIP op op db)+    => TransTIPM1 True n m (m' op) db where+    ttipM1 _ _ op db = do+         op' <- op+         return $ tipyUpdate op' db++instance (Fail (FieldNotFound op (TIP db)), Monad m)+    => TransTIPM1 False HZero m op db where+    ttipM1 _ _ = error "TransTIPM1 Fail failed"++-- If op is not found in a TIP, it must be a function. Look up+-- its argument in a TIP and recur.+instance (Monad m,+          HMember (Tagged arg arg) db b,+          TransTIPM2 b m arg op db)+    => TransTIPM1 False (HSucc n) m (arg-> op) db where+    ttipM1 _ _ = ttipM2 (Proxy :: Proxy b)+++class TransTIPM2 (b :: Bool) m arg op db where+    ttipM2 :: Proxy b -> (arg -> op) -> TIP db -> m (TIP db)++instance (HOccurs arg (TIP db), TransTIPM m op db)+      => TransTIPM2 True m arg op db where+    ttipM2 _ f db = ttipM (f (hOccurs db)) db+++instance Fail (FieldNotFound op (TIP db))+    => TransTIPM2 False m arg op db where+    ttipM2 _ _ = error "TransTIPM1 Fail failed"++-- --------------------------------------------------------------------------++-- tests for tipyTuple. These only work if tipyTuple is compiled+-- in a module that has NoMonoLocalBinds enabled+_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Char, Bool)+_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Bool, Char)+++-- --------------------------------------------------------------------------++-- * Sample code++{- $setup++[@Assume@]++>>> import Data.HList.TypeEqO+>>> import Data.HList.FakePrelude+>>> import Data.HList.HOccurs++>>> :{+newtype Key    = Key Integer deriving (Show,Eq,Ord)+newtype Name   = Name String deriving (Show,Eq)+data Breed     = Cow | Sheep deriving (Show,Eq)+newtype Price  = Price Float deriving (Show,Eq,Ord)+data Disease   = BSE | FM deriving (Show,Eq)+type Animal =  TagR '[Key,Name,Breed,Price]+:}++>>> :{+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+:}++-}++{- $sessionlog+[@Session log@]++>>> :t myTipyCow+myTipyCow+  :: TIP+       '[Tagged Key Key, Tagged Name Name, Tagged Breed Breed,+         Tagged Price Price]++>>> hOccurs myTipyCow :: Breed+Cow++>>> BSE .*. myTipyCow+TIPH[BSE,Key 42,Name "Angus",Cow,Price 75.5]++++>>> 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]+++>>> 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]++-}+++{- $sessionlog2++Don't bother repeating the type error:+++>>> Sheep .*. myTipyCow+...+...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/TypeCastGeneric1.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}--{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   A generic implementation of type cast. For this implementation to-   work, we need to import it at a higher level in the module hierarchy-   than all clients of the class. Otherwise, type simplification will-   inline TypeCast x y, which implies compile-time unification of x and y.--   This technique works fine for ghc, and within limits for hugs.--}--module Data.HList.TypeCastGeneric1 where--import Data.HList.FakePrelude--instance TypeCast x x- where-  typeCast = id
− Data/HList/TypeCastGeneric2.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}-{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   A generic implementation of a type-safe cast. The specific coding-   here is only shown for completeness' sake and it is explained in the-   TR version of the paper. The shown coding does not rely on separate-   compilation (while "Data.HList.TypeCastGeneric1" does), but on some other-   tricks.--}--module Data.HList.TypeCastGeneric2 where---- We make everything self-contained to show that separate compilation--- is not needed.--import Data.HList.FakePrelude () -- hiding (TypeCast,typeCast)---{-----------------------------------------------------------------------------}---- The actual encoding--class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b-class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b-class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b-instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x-instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''-instance TypeCast'' () a a where typeCast'' _ x  = x---{-----------------------------------------------------------------------------}
− Data/HList/TypeEqBoolGeneric.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}-{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Generic implementations of type equality and disequality--}--module Data.HList.TypeEqBoolGeneric where--import Data.HList.FakePrelude--instance            TypeEqTrue  x x-instance Fail () => TypeEqFalse x x-instance            TypeEqFalse x y
− Data/HList/TypeEqGeneric1.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  FlexibleContexts, OverlappingInstances, UndecidableInstances #-}-{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   A generic implementation of a type equality predicate. The given-   implementation only works for GHC. It relies on two properties-   of GHC instance selection: (i) selection is lazy, and the negation-   of the constraints of the more specific instance is assumed for-   the more general instance.--   The specific encoding given here makes use of TypeCast,-   and by transitive closure therefore relies on separate compilation-   of TypeCast clients and the TypeCast instance.--   There is another encoding in "Data.Hlist.TypeEqGeneric2".--}--module Data.HList.TypeEqGeneric1 where--import Data.HList.FakePrelude--instance TypeEq x x HTrue-instance (HBool b, TypeCast HFalse b) => TypeEq x y b--- instance TypeEq x y HFalse -- would violate functional dependency---class HBool b => TupleType t b | t -> b-instance TupleType () HTrue-instance TupleType (x,y) HTrue-instance TupleType (x,y,z) HTrue--- Continue for a while-instance (HBool b, TypeCast HFalse b) => TupleType x b--- instance TupleType x HFalse -- would violate functional dependency
− Data/HList/TypeEqGeneric2.hs 
@@ -1,50 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, UndecidableInstances, OverlappingInstances #-}--{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   A generic implementation of a type equality predicate. The given-   implementation only works for GHC. The specific coding here is only-   shown for completeness' sake. We actually favour the encoding from-   "Data.Hlist.TypeEqGeneric1" for its conciseness. The specific coding here-   does not rely on separate compilation (while TypeEqGeneric1.hs-   does), but on some other tricks.--}--module Data.HList.TypeEqGeneric2 where---- We make everything self-contained to show that separate compilation--- is not needed. Also, we need a new class constraint for TypeEqBool,--- (unless we again employ separate compilation in some ways) so--- that instance selection of its generic instance within client code--- of TypeEqBool does not issue problems with the instance--- constraints.--import Data.HList.FakePrelude hiding (TypeEq,typeEq,proxyEq,TypeCast,typeCast)-import Data.HList.TypeCastGeneric2---- Re-enabled for testing--typeEq :: TypeEq t t' b => t -> t' -> b-typeEq = undefined---{-----------------------------------------------------------------------------}---- The actual encoding--class TypeEq' () x y b => TypeEq x y b | x y -> b-class TypeEq' q x y b | q x y -> b-class TypeEq'' q x y b | q x y -> b-instance TypeEq' () x y b => TypeEq x y b--- This instance used to work <= GHC 6.2--- instance TypeEq' () x x HTrue--- There were some problems however with GHC CVS 6.3.--- So we favour the following, more stable (?) instance instead.-instance TypeCast b HTrue => TypeEq' () x x b-instance TypeEq'' q x y b => TypeEq' q x y b-instance TypeEq'' () x y HFalse--{-----------------------------------------------------------------------------}
+ Data/HList/TypeEqO.hs view
@@ -0,0 +1,55 @@+{-# 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:+   The implementation based on overlapping instances+   The only place where overlapping instances are really used+   besides Label5++-}++module Data.HList.TypeEqO where++import Data.HList.FakePrelude++#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 {-# OVERLAPPING #-} TupleType () True+instance {-# OVERLAPPING #-} TupleType (x,y) True+instance {-# OVERLAPPING #-} TupleType (x,y,z) True+-- Continue for a while+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,98 +1,1185 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  UndecidableInstances, FlexibleContexts #-}--{- |-   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.HListPrelude-import Data.HList.HArray-import Data.HList.Record---{-----------------------------------------------------------------------------}---- | Variant types on the basis of label-maybe pairs.--newtype Variant mr = Variant mr---{-----------------------------------------------------------------------------}---- | Turn proxy sequence into sequence of Nothings--class HMaybied r r' | r -> r'- where-  hMaybied :: r -> r'--instance HMaybied HNil HNil- where-  hMaybied _ = HNil--instance HMaybied r r'-      => HMaybied (HCons (LVPair l (Proxy v)) r) (HCons (LVPair l (Maybe v)) r')- where-  hMaybied (HCons _ r) = HCons (LVPair Nothing) (hMaybied r)---{-----------------------------------------------------------------------------}---- | Public constructor--mkVariant :: ( RecordLabels v ls-             , HFind x ls n-             , HMaybied v v'-             , HUpdateAtHNat n (LVPair x (Maybe y)) v' v'-             )-          => x -> y -> (Record v) -> Variant v'--mkVariant x y (Record v) = Variant v'- where-  n       = hFind x (recordLabels' v)-  ms      = hMaybied v-  v'      = hUpdateAtHNat n (newLVPair x (Just y)) ms---{-----------------------------------------------------------------------------}---- | Public destructor--unVariant :: ( RecordLabels v ls-             , HFind x ls n-             , HLookupByHNat n v (LVPair x (Maybe y))-             )-          => x -> Variant v -> Maybe y--unVariant x (Variant v) = y- where-  n       = hFind x (recordLabels' v)-  LVPair y     = hLookupByHNat n v---{-----------------------------------------------------------------------------}---- | Variants are opaque--instance Show (Variant v)- where-  show _ = "<Cannot show Variant content!>"---{-----------------------------------------------------------------------------}+{-# LANGUAGE CPP #-}++{- |+   Description: Variants, i.e., labelled sums, generalizations of Either++   The HList library++   See <Data-HList-CommonMain.html#t:Variant CommonMain#Variant>+   for the public (safe) interface.++   The implementation here follows "Data.Dynamic", though Typeable is not+   needed.++   See @broken/VariantP.hs@ and @broken/VariantOld.hs@ for different approaches+   to open sums.+-}++module Data.HList.Variant where++import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.HList+import Data.HList.HListPrelude+import Data.HList.HOccurs()+import Data.HList.HArray++import Text.ParserCombinators.ReadP hiding (optional)++import Unsafe.Coerce+import GHC.Exts (Constraint)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup( .. ))+#endif+import Data.Data+import Control.Applicative+import LensDefs+import Control.Monad++-- * Labels for doctests++{- $setup++>>> import Data.HList.RecordPuns+>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let z = Label :: Label "z"+>>> let _left = Label :: Label "left"+>>> let _right = Label :: Label "right"++>>> :set -XQuasiQuotes -XViewPatterns -XDataKinds+++-- * Creating Variants++It is necessary to specify the order in which the fields occur, using+a data type like++>>> let p = Proxy :: Proxy '[Tagged "left" Char, Tagged "right" Int]++Then this argument can be passed into 'mkVariant'++>>> let v = mkVariant _left 'x' p+>>> let w = mkVariant _right 5  p++>>> :t v+v :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w+w :: Variant '[Tagged "left" Char, Tagged "right" Int]+++>>> [v,w]+[V{left='x'},V{right=5}]++-}+++-- ** Alternative: a 'Record' as the Proxy+{- $mkVariant2++The type of mkVariant also allows using a 'Record' as the proxy. For example:++>>> :{+let p2 = [pun| left right |] where+            left = 'a'+            right = (4::Int)+:}++>>> let v2 = mkVariant _left 'x' p2+>>> let w2 = mkVariant _right 5  p2++>>> :t v2+v2 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w2+w2 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> (v2,w2)+(V{left='x'},V{right=5})++-}++-- ** A polymorphic Proxy+{- $mkVariant3++It is also possible to leave the @Char@ and @Int@ as type variables,+and have them inferred.++>>> let p3 = Proxy :: Proxy '[Tagged "left" a, Tagged "right" b]++Using @p3@ takes some care. The following attempt shows the problem:++>>> :{+let v3' = mkVariant _left 'x' p3+    w3' = mkVariant _right (5::Int) p3+:}++>>> :t v3'+v3' :: Variant '[Tagged "left" Char, Tagged "right" b]++>>> :t w3'+w3' :: Variant '[Tagged "left" a, Tagged "right" Int]++Here each use of @p3@ does not constrain the type of the other use.+In some cases those type variables will be inferred from other constraints,+such as when putting the variants into a list++>>> [v3', w3']+[V{left='x'},V{right=5}]++In other cases the other tags will be defaulted to (), at least if `ExtendedDefaultRules` is enabled:++>>> v3'+V{left='x'}++>>> :set -XNoExtendedDefaultRules+>>> v3'+...+...No instance for (Show ...) arising from a use of ‘print’+...+++Another way around this issue is to make sure that the proxy+is bound in a monomorphic pattern. These are patterns that allow+name shadowing.++* @\p -> ...@+* @case e of p -> ...@+* @do p <- e; ...@+* implicit parameters @let ?p = e in ...@+* <http://stackoverflow.com/questions/23899279#23899611 other patterns involved in mutually recursive bindings>++An example of the case:++>>> :{+let (v3,w3) = case p3 of+              p -> (mkVariant _left 'x' p,+                    mkVariant _right (5 :: Int) p)+:}+++>>> :t v3+v3 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w3+w3 :: Variant '[Tagged "left" Char, Tagged "right" Int]++-}++-- --------------------------------------------------------------------------+{- |+@Variant vs@ has an implementation similar to 'Dynamic', except the+contained value is one of the elements of the @vs@ list, rather than+being one particular instance of 'Typeable'.++>>> v .!. _right+Nothing++>>> v .!. _left+Just 'x'++In some cases the 'pun' quasiquote works with variants,++>>> let f [pun| left right |] = (left,right)+>>> f v+(Just 'x',Nothing)++>>> f w+(Nothing,Just 5)+++>>> let add1 v = hMapV (Fun succ :: Fun '[Enum] '()) v++>>> f (add1 v)+(Just 'y',Nothing)++>>> f (add1 w)+(Nothing,Just 6)+++-}+data Variant (vs :: [*]) = Variant !Int Any++#if __GLASGOW_HASKELL__ > 707+-- the inferred role is phantom, which is not safe+type role Variant representational+#endif++++-- ** Unsafe operations++-- | This is only safe if the n'th element of vs has type @Tagged t v@+unsafeMkVariant :: Int -- ^ n+                -> v+                -> Variant vs+unsafeMkVariant n a = Variant n (unsafeCoerce a)++{- | Safe when (e ~ e') given that++> Tagged t e ~ HLookupByHNatR n v+> Tagged t' e' ~ HLookupByHNatR n v'++'hUpdateAtLabel' is the safe version++-}+unsafeCastVariant :: Variant v -> Variant v'+unsafeCastVariant (Variant n e) = Variant n e++-- | in ghc>=7.8, 'Data.Coerce.coerce' is probably a better choice+castVariant :: (RecordValuesR v ~ RecordValuesR v',+              SameLength v v') => Variant v -> Variant v'+castVariant = unsafeCastVariant++instance Relabeled Variant where+    relabeled = iso castVariant castVariant++-- | private destructor. This is safe only if the value+-- contained actually has type `e`+unsafeUnVariant :: Variant v -> e+unsafeUnVariant (Variant _ e) = unsafeCoerce e+++{- | This function is unsafe because it can lead to a runtime error+when used together with the 'HExtend' instance (.*.)++>>> print $ (Label :: Label "x") .=. (Nothing :: Maybe ()) .*. unsafeEmptyVariant+V{*** Exception: invalid variant++use 'mkVariant1' instead++-}+unsafeEmptyVariant :: Variant '[]+unsafeEmptyVariant = unsafeMkVariant 0 ()++-- --------------------------------------------------------------------------+-- * Public constructor++class HasField x (Variant vs) (Maybe v) =>+      MkVariant x v vs | x vs -> v where+    mkVariant :: Label x -- ^ the tag+        -> v -- ^ value to be stored+        -> proxy vs -- ^ a helper to fix the ordering and types of the+                    -- potential values that this variant contains.+                    -- Typically this will be a 'Proxy', 'Record' or+                    -- another 'Variant'+        -> Variant vs++mkVariant1 l v = l .=. Just v .*. unsafeEmptyVariant++instance (HFindLabel x vs n,+          HNat2Integral n,+          HasField x (Variant vs) (Maybe v)) =>+    MkVariant x v vs where+  mkVariant _x y _p = unsafeMkVariant (hNat2Integral (Proxy :: Proxy n)) y+  -- done as a one-instance class instead of a function to be able to hide+  -- the 'n' type variable++-- --------------------------------------------------------------------------+-- * Public destructor++{- $note 'hLookupByLabel' (synonym '.!.')++> (.!.)             :: Variant v -> Label x -> Maybe e+> hLookupByLabel    :: Label x -> Variant v -> Maybe e++'hPrism' and 'hLens'' combine this with 'mkVariant'+-}+instance (HasField x (Record vs) a,+          HFindLabel x vs n,+          HNat2Integral n)+  => HasField x (Variant vs) (Maybe a) where+  hLookupByLabel _x (Variant n d)+          | hNat2Integral (Proxy :: Proxy n) == n = Just (unsafeCoerce d)+          | otherwise = Nothing++splitVariant1 :: Variant (Tagged s x ': xs) -> Either x (Variant xs)+splitVariant1 (Variant 0 x) = Left (unsafeCoerce x)+splitVariant1 (Variant n x) = Right (Variant (n-1) x)++-- | x ~ Tagged s t+splitVariant1' :: Variant (x ': xs) -> Either x (Variant xs)+splitVariant1' (Variant 0 x) = Left (unsafeCoerce x)+splitVariant1' (Variant n x) = Right (Variant (n-1) x)++extendVariant :: Variant l -> Variant (e ': l)+extendVariant (Variant m e) = Variant (m+1) e++-- --------------------------------------------------------------------------+-- * Prism++{- | Make a @Prism (Variant s) (Variant t) a b@ out of a Label.++See "Data.HList.Labelable".'hLens'' is a more overloaded version.++Few type annotations are necessary because of the restriction+that `s` and `t` have the same labels in the same order, and to+get \"t\" the \"a\" in \"s\" is replaced with \"b\".++-}+class (SameLength s t, SameLabels s t)+        => HPrism x s t a b+          | x s -> a, x t -> b,    -- lookup+            x s b -> t, x t a -> s -- update+  where+    hPrism :: (Choice p, Applicative f)+        => Label x -> p a (f b) -> p (Variant s) (f (Variant t))+++instance (+    MkVariant x b t,++    HasField x (Variant s) (Maybe a),++    -- labels in the HList are not changed at all:+    -- number, ordering, actual values are all constant+    SameLength s t,+    SameLabels s t,++    -- only the target of the prism can have it's type changed+    H2ProjectByLabels '[Label x] s si so,+    H2ProjectByLabels '[Label x] t ti to,+    so ~ to,++    -- to convince GHC the fundeps are satisfied+    HUpdateAtLabel Variant x b s t,+    HUpdateAtLabel Variant x a t s+   ) => HPrism x s t a b where+    hPrism x = prism (\b -> mkVariant x b Proxy)+                  (\s -> case hLookupByLabel x s of+                    Just a -> Right a+                    Nothing -> Left (unsafeCastVariant s :: Variant t))++++-- --------------------------------------------------------------------------+-- * Read+-- | Variants are not opaque+instance (ShowVariant vs) => Show (Variant vs) where+    showsPrec _ v = ("V{"++) . showVariant v . ('}':)+++-- | helper class for defining the Show instance+class ShowVariant vs where+    showVariant :: Variant vs -> ShowS++instance (ShowLabel l, Show v, ShowVariant (w ': ws))+      => ShowVariant (Tagged l v ': w ': ws) where+    showVariant vs = case splitVariant1 vs of+        Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest+        Right wws -> showVariant wws+      where l = Label :: Label l++instance (ShowLabel l, Show v, lv ~ Tagged l v) => ShowVariant '[lv] where+    showVariant vs = case splitVariant1 vs of+        Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest+        Right _ -> error "invalid variant"+      where l = Label :: Label l++-- --------------------------------------------------------------------------+-- * Show+-- | A corresponding read instance++instance ReadVariant v => Read (Variant v) where+    readsPrec _ = readP_to_S $ do+      _ <- string "V{"+      r <- readVariant+      _ <- string "}"+      return r++class ReadVariant vs where+    readVariant :: ReadP (Variant vs)++instance ReadVariant '[] where+    readVariant = return unsafeEmptyVariant++instance (ShowLabel l, Read v, ReadVariant vs,+          HOccursNot (Label l) (LabelsOf vs))+    => ReadVariant (Tagged l v ': vs) where+    readVariant = do+      mlv <- optional lv+      case mlv of+        Nothing -> do+          rest <- readVariant+          return (l .=. mlv .*. rest)+        Just e -> do+          return (mkVariant l e p)++      where+        lv = do+            _ <- string (showLabel l)+            _ <- string "="+            readS_to_P reads++        l = Label :: Label l++        p = Proxy :: Proxy (Tagged l v ': vs)+++-- * Data+instance (Typeable (Variant v), GfoldlVariant v v,+          GunfoldVariant v v,+          VariantConstrs v)+        => Data (Variant v) where+    gfoldl = gfoldlVariant+    gunfold k z c = gunfoldVariant (\con -> k (z con)) (Proxy :: Proxy v) (constrIndex c - 1)+    toConstr v@(Variant n _) = case drop n (variantConstrs (dataTypeOf v) v) of+        c : _ -> c+        _ -> error "Data.HList.Variant.toConstr impossible"+    dataTypeOf x = let self = mkDataType (show (typeOf x)) (variantConstrs self x)+          in self++class VariantConstrs (xs :: [*]) where+  variantConstrs :: DataType -> proxy xs -> [Constr]++instance VariantConstrs '[] where+  variantConstrs _ _ = []++instance (ShowLabel l, VariantConstrs xs) => VariantConstrs (Tagged l e ': xs) where+  variantConstrs dt _ = mkConstr dt (showLabel (Label :: Label l)) [] Prefix :+        variantConstrs dt (Proxy :: Proxy xs)+++++{- | [@implementation of gunfold for Variant@]++In ghci++> :set -ddump-deriv -XDeriveDataTypeable+> data X a b c = A a | B b | C c deriving (Data,Typeable)++shows that gunfold is defined something like++> gunfold k z c = case constrIndex c of+>       1 -> k (z Ghci1.A)+>       2 -> k (z Ghci1.B)+>       _ -> k (z Ghci1.C)++If we instead had++> type X a b c = Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]++Then we could write:++> gunfold1 :: (forall b r. Data b => (b -> r) -> c r)+>          -> Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]+> gunfold1 f c = case constrIndex c of+>       1 -> f mkA+>       2 -> f mkB+>       _ -> f mkC+>   where mkA a = mkVariant (Label :: Label "A") (a :: a) v+>         mkB b = mkVariant (Label :: Label "B") (b :: b) v+>         mkC c = mkVariant (Label :: Label "C") (c :: c) v+>         v = Proxy :: Proxy [Tagged "A" a, Tagged "B" b, Tagged "C" c]++where @f = k.z@+++-}+class GunfoldVariant (es :: [*]) v where+    gunfoldVariant ::+        (forall b. Data b => (b -> Variant v) -> c (Variant v))+          -- ^ @f = k . z@+        -> Proxy es+        -> Int+        -> c (Variant v)++instance (MkVariant l e v, Data e) => GunfoldVariant '[Tagged l e] v where+    gunfoldVariant f _ _ = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy)++instance (MkVariant l e v, Data e,+        GunfoldVariant (b ': bs) v) => GunfoldVariant (Tagged l e ': b ': bs)  v where+    gunfoldVariant f _ 0 = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy)+    gunfoldVariant f _ n = gunfoldVariant f (Proxy :: Proxy (b ': bs)) (n-1)++++class GfoldlVariant xs xs' where+  -- | the same as 'gfoldl', except the variant that is returned can have more+  -- possible values (needed to actually implement gfoldl).+  gfoldlVariant ::+     (forall d b. Data d => c (d -> b) -> d -> c b)+     -> (forall g. g -> c g) -> Variant xs -> c (Variant xs')++instance (a ~ Tagged l v, MkVariant l v r, Data v,+          GfoldlVariant (b ': c) r)+      => GfoldlVariant (a ': b ': c) r where+  gfoldlVariant k z xxs = case splitVariant1 xxs of+      Right xs -> gfoldlVariant k z xs+      -- If the c@type variable in 'gfoldl' had a Functor constraint,+      -- this case could be extendVariant `fmap` gfoldl k z xs,+      -- and then 'GfoldlVariant' would be unnecessary+      Left x ->+            let mkV e = mkVariant (Label :: Label l) e Proxy+            in z mkV `k` x++instance (Unvariant '[a] v, a ~ Tagged l v, Data v,+          MkVariant l v b) => GfoldlVariant '[a] b where+    gfoldlVariant k z xxs = z mkV `k` unvariant xxs+        where mkV e = mkVariant (Label :: Label l) e Proxy++++-- --------------------------------------------------------------------------+-- * Map+-- | Apply a function to all possible elements of the variant+newtype HMapV f = HMapV f++-- | shortcut for @applyAB . HMapV@. 'hMap' is more general+hMapV f v = applyAB (HMapV f) v++-- | @hMapOutV f = unvariant . hMapV f@, except an ambiguous type+-- variable is resolved by 'HMapOutV_gety'+hMapOutV :: forall x y z f. (SameLength x y,+      HMapAux Variant (HFmap f) x y,+      Unvariant y z,+      HMapOutV_gety x z ~ y+  ) => f -> Variant x -> z+hMapOutV f v = unvariant (hMapV f v :: Variant y)+++-- | resolves an ambiguous type in 'hMapOutV'+type family HMapOutV_gety (x :: [*]) (z :: *) :: [*]+type instance HMapOutV_gety (Tagged s x ': xs) z = Tagged s z ': HMapOutV_gety xs z+type instance HMapOutV_gety '[] z = '[]+++-- | apply a function to all values that could be in the variant.+instance (vx ~ Variant x,+          vy ~ Variant y,+          HMapAux Variant (HFmap f) x y,+          SameLength x y)+     => ApplyAB (HMapV f) vx vy where+    applyAB (HMapV f) x = hMapAux (HFmap f) x++instance (ApplyAB f te te') => HMapAux Variant f '[te] '[te'] where+    hMapAux f v = case splitVariant1' v of+        Left te -> unsafeMkVariant 0 (applyAB f te :: te')+        Right _ -> error "HMapVAux: variant invariant broken"++instance (ApplyAB f te te',+          HMapCxt Variant f (l ': ls) (l' ': ls'))+    => HMapAux Variant f (te ': l ': ls) (te' ': l' ': ls') where+      hMapAux f v = case splitVariant1' v of+          Left te -> unsafeMkVariant 0 (applyAB f te :: te')+          Right es -> extendVariant (hMapAux f es)++-- --------------------------------------------------------------------------+-- * HUpdateAtLabel instance++{- |++> hUpdateAtLabel x e' (mkVariant x e proxy) == mkVariant x e' proxy+> hUpdateAtLabel y e' (mkVariant x e proxy) == mkVariant x e  proxy++-}+instance+   (HUpdateVariantAtLabelCxt l e v v' n _e) =>+    HUpdateAtLabel Variant l e v v' where+    hUpdateAtLabel l e v = case hLookupByLabel l v of+          Just _e -> mkVariant l e (Proxy :: Proxy v')+          Nothing -> unsafeCastVariant v++type HUpdateVariantAtLabelCxt l e v v' n _e =+   (HFindLabel l v n,+    HFindLabel l v' n,+    HUpdateAtHNatR n (Tagged l e) v ~ v',+    HasField l (Variant v) (Maybe _e),+    HasField l (Record v') e,+    MkVariant l e v')+++-- --------------------------------------------------------------------------+-- * HExtend instance+{- | Extension for Variants prefers the first value++> (l .=. Nothing) .*. v = v+> (l .=. Just e)  .*. _ = mkVariant l e Proxy++-}+instance (le ~ Tagged l (Maybe e), HOccursNot (Label l) (LabelsOf v)) =>+    HExtend le (Variant v) where+    type HExtendR le (Variant v) = Variant (UnMaybe le ': v)+    Tagged (Just e) .*. _ = unsafeMkVariant 0 e+    Tagged Nothing .*. (Variant n e) = Variant (n+1) e++type family UnMaybe le+type instance UnMaybe (Tagged l (Maybe e)) = Tagged l e++-- | used for 'HExtend' 'TIP'+type instance UnMaybe (Maybe e) = e+++-- --------------------------------------------------------------------------+-- * Conversion to an untagged value+class HAllEqVal (x :: [*]) (b :: Bool) | x -> b+instance HAllEqVal '[] True+instance HAllEqVal '[x] True+instance (HEq a a' b,+          HAllEqVal (Tagged t a' ': xs) b2,+          HAnd b b2 ~ b3) =>+  HAllEqVal (Tagged s a ': Tagged t a' ': xs) b3+++class HAllEqVal' (x :: [*])+instance HAllEqVal' '[]+instance HAllEqVal' '[x]+instance (HAllEqVal' (ta ': xs),+          a' ~ a,+          ta ~ Tagged t a,+          ta' ~ Tagged t' a')+  => HAllEqVal' (ta' ': ta ': xs)+++{- | Similar to 'unvariant', except type variables in @v@+will be made equal to @e@ if possible. That allows the type+of @Nothing@ to be inferred as @Maybe Char@.++>>> unvariant' $ x .=. Nothing .*. mkVariant1 y 'y'+'y'++However, this difference leads to more local error messages+(@Couldn't match type ‘()’ with ‘Char’@), rather than the following+with @unvariant@:++> Fail+>    '("Variant",+>      '[Tagged "left" Char, Tagged "right" ()],+>      "must have all values equal to ",+>      e))++-}+class Unvariant' v e | v -> e where+    unvariant' :: Variant v -> e++instance (HAllEqVal' (Tagged () e ': v), Unvariant v e) =>+    Unvariant' v e where+  unvariant' = unvariant++{- | Convert a Variant which has all possibilities having the same type+into a value of that type. Analogous to @either id id@.++See also 'unvariant'' -}+class Unvariant v e | v -> e where+    unvariant :: Variant v -> e++instance (Unvariant1 b v e,+          HAllEqVal v b,+          HAllEqVal (Tagged () e ': v) b)+    => Unvariant v e where+      unvariant = unvariant1 (Proxy :: Proxy b)+++class Unvariant1 b v e | b v -> e where+    unvariant1 :: Proxy b -> Variant v -> e++instance (v ~ Tagged t1 e)+    => Unvariant1 True (v ': vs) e where+    unvariant1 _ = unsafeUnVariant++data UnvariantTypeMismatch (vs :: [*])++instance Fail (UnvariantTypeMismatch (v ': vs))+      => Unvariant1 False (v ': vs) (UnvariantTypeMismatch (v ': vs)) where+    unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances"++instance Fail "Unvariant applied to empty variant"+      => Unvariant1 b '[] (Proxy "Unvariant applied to empty variant") where+    unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances"++{- | @Lens (Variant s) (Variant t) a b@++Analogue of @Control.Lens.chosen :: Lens (Either a a) (Either b b) a b@+-}+unvarianted :: (Unvariant' s a,+                Unvariant' t b,+                SameLabels s t, -- extra constraints to reduce ambiguity+                SameLength s t,+                Functor f) =>+    (a -> f b) -> Variant s -> f (Variant t)+unvarianted f v@(Variant n _) = fmap (\e' -> unsafeMkVariant n e')+                                      (f (unvariant' v))++-- | @Lens' (Variant s) a@+--+-- where we might have @s ~ '[Tagged t1 a, Tagged t2 a]@+unvarianted' x = simple (unvarianted x)++-- * Zip++{- | Applies to variants that have the same labels+in the same order. A generalization of++> zipEither :: Either a b -> Either a b -> Maybe (Either (a,a) (b,b))+> zipEither (Left a) (Left a') = Just (Left (a,a'))+> zipEither (Right a) (Right a') = Just (Right (a,a'))+> zipEither _ _ = Nothing++see 'HZip' for zipping other collections++-}+class ZipVariant x y xy | x y -> xy, xy -> x y where+    zipVariant :: Variant x -> Variant y -> Maybe (Variant xy)++instance ZipVariant '[] '[] '[] where+    zipVariant _ _ = Nothing++instance (tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y),+          ZipVariant xs ys zs,+          MkVariant t (x,y) (txy ': zs))+  => ZipVariant (tx ': xs) (ty ': ys) (txy ': zs) where+    zipVariant x y = case (splitVariant1 x, splitVariant1 y) of+        (Left x', Left y') -> Just (mkVariant (Label :: Label t) (x',y') Proxy)+        (Right x', Right y') -> extendVariant <$> zipVariant x' y'+        _ -> Nothing+++instance (HUnzip Variant (x2 ': xs) (y2 ': ys) (xy2 ': xys),+          SameLength xs ys,+          SameLength ys xys,+          tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y))+      => HUnzip Variant (tx ': x2 ': xs) (ty ': y2 ': ys) (txy ': xy2 ': xys) where+    hUnzip xy = case splitVariant1 xy of+      Left (x,y) -> (mkVariant (Label :: Label t) x Proxy,+                     mkVariant (Label :: Label t) y Proxy)+      Right xy' | (x,y) <- hUnzip xy' ->+                    (extendVariant x,+                     extendVariant y)++instance (Unvariant '[txy] txy,+          tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y))+      => HUnzip Variant '[tx] '[ty] '[txy] where+    hUnzip xy | Tagged (x,y) <- unvariant xy =+        (mkVariant1 Label x, mkVariant1 Label y)+++-- ** with a record++{- | Apply a record of functions to a variant of values.+The functions are selected based on those having the same+label as the value.++-}+class (SameLength v v',+       SameLabels v v')  => ZipVR fs v v' | fs v -> v' where+    -- | 'zipVR' is probably a better choice in most+    -- situations, since it requires that @fs@ has one function for every+    -- element of @v@+    zipVR_ :: Record fs -> Variant v -> Variant v'++instance (lv ~ Tagged l v,+          lv' ~ Tagged l v',+          HMemberM (Label l) (LabelsOf fs) b,+          HasFieldM l (Record fs) f,+          DemoteMaybe (v -> v) f ~ (v -> v'),+          MkVariant l v' (lv' ': rs),+          ZipVR fs vs rs) =>+          ZipVR fs (lv ': vs) (lv' ': rs) where+    zipVR_ r lvs = case splitVariant1 lvs of+                  Left v | v' <- hLookupByLabelM l r (id :: v -> v) v -> mkVariant l v' Proxy+                  Right vs -> extendVariant $ zipVR_ r vs+      where l = Label :: Label l+++instance ZipVR fs '[] '[] where+    zipVR_ _ x = x++{- |++>>> let xy = x .*. y .*. emptyProxy+>>> let p = Proxy `asLabelsOf` xy+>>> let vs = [ mkVariant x 1.0 p, mkVariant y () p ]+++>>> zipVR (hBuild (+1) id) `map` vs+[V{x=2.0},V{y=()}]+++-}+zipVR :: (SameLabels fs v, SameLength fs v, ZipVR fs v v',+          ZipVRCxt fs v v')+    => Record fs -> Variant v -> Variant v'+zipVR = zipVR_+++{- | Lets 'zipVR' act as if @'ZipVR' fs v v'@ had an FD @v v' -> fs@++> ZipVRCxt [Tagged s f,  Tagged t g]+>          [Tagged s fx, Tagged t gx]+>          [Tagged s fy, Tagged t gy]+>   = (f ~ (fx -> fy), g ~ (gx -> gy))++-}+type family ZipVRCxt (fs :: [*]) (xs :: [*]) (ys :: [*]) :: Constraint++type instance ZipVRCxt (Tagged s f ': fs) (Tagged s x ': xs) (Tagged s y ': ys) =+        (f ~ (x -> y), ZipVRCxt fs xs ys)+type instance ZipVRCxt '[] '[] '[] = ()++-- * Eq+instance Eq (Variant '[]) where+  _ == _ = True++instance (Eq (Variant xs), Eq x) => Eq (Variant (x ': xs)) where+  v == v' = case (splitVariant1' v, splitVariant1' v') of+    (Left l, Left r) -> l == r+    (Right l, Right r) -> l == r+    _ -> False++-- ** Alternative Eq+-- | implemented like @and (zipWith (==) xs ys)@. Behaves the same as the Eq instances for 'Variant'+eqVariant v v' = maybe False (hMapOutV UncurryEq) $ zipVariant v v'++data UncurryEq = UncurryEq++instance (ee ~ (e,e), Eq e, bool ~ Bool) =>+    ApplyAB UncurryEq ee bool where+      applyAB _ (e,e') = e == e'++-- * Ord+instance Ord (Variant '[]) where+  compare _ _ = EQ++instance (Ord x, Ord (Variant xs)) => Ord (Variant (x ': xs)) where+  compare a b = compare (splitVariant1' a) (splitVariant1' b)++-- * Bounded+instance (Bounded x, Bounded z,+          HRevAppR (Tagged s x ': xs) '[] ~ (Tagged t z ': sx),+          MkVariant t z (Tagged s x ': xs))+        => Bounded (Variant (Tagged s x ': xs)) where+  minBound = mkVariant (Label :: Label s) (minBound :: x) Proxy+  maxBound = mkVariant (Label :: Label t) (maxBound :: z) Proxy++-- * Enum+{- |++>>> let t = minBound :: Variant '[Tagged "x" Bool, Tagged "y" Bool]+>>> [t .. maxBound]+[V{x=False},V{x=True},V{y=False},V{y=True}]+++[@Odd behavior@]+There are some arguments that this instance should not exist.++The last type in the Variant does not need to be Bounded. This+means that 'enumFrom' behaves a bit unexpectedly:++>>> [False .. ]+[False,True]++>>> [t .. ]+[V{x=False},V{x=True},V{y=False},V{y=True},V{y=*** Exception: Prelude.Enum.Bool.toEnum: bad argument++This is a \"feature\" because it allows an @Enum (Variant '[Tagged \"a\" Bool, Tagged \"n\" 'Integer'])@++Another difficult choice is that the lower bound is @fromEnum 0@ rather than @minBound@:++>>> take 5 [ minBound :: Variant '[Tagged "b" Bool, Tagged "i" Int] .. ]+[V{b=False},V{b=True},V{i=0},V{i=1},V{i=2}]++-}+instance (Enum x, Bounded x, Enum (Variant (y ': z))) => Enum (Variant (Tagged s x ': y ': z)) where+  fromEnum v = case splitVariant1 v of+    Left x -> fromEnum x+    Right yz -> 1 + fromEnum (maxBound :: Tagged s x) + fromEnum yz++  toEnum n+      | m >= n = mkVariant (Label :: Label s) (toEnum n) Proxy+      | otherwise = extendVariant $ toEnum (n - m - 1)+    where m = fromEnum (maxBound :: Tagged s x)++{- |++While the instances could be written Enum (Variant '[])+Eq/Ord which cannot produce values, so they have instances for+empty variants ('unsafeEmptyVariant'). Enum can produce values,+so it is better that @fromEnum 0 :: Variant '[]@ fails with No instance for+@Enum (Variant '[])@ than producing an invalid variant.++-}+instance Enum x => Enum (Variant '[Tagged s x]) where+  fromEnum v = case splitVariant1 v of+    Left x -> fromEnum x+    _ -> error "Data.HList.Variant fromEnum impossible"+  toEnum n = mkVariant (Label :: Label s) (toEnum n) Proxy++-- * Ix (TODO)++-- * Semigroup+instance (Unvariant '[Tagged t x] x, Semigroup x) => Semigroup (Variant '[Tagged t x]) where+    a <> b = case (unvariant a, unvariant b) of+                    (l, r) -> mkVariant (Label :: Label t) (l <> r) Proxy++instance (Semigroup x, Semigroup (Variant (a ': b))) => Semigroup (Variant (Tagged t x ': a ': b)) where+    a <> b = case (splitVariant1 a, splitVariant1 b) of+                    (Left l, Left r) -> mkVariant (Label :: Label t) (l <> r) Proxy+                    (Left l, _) -> mkVariant (Label :: Label t) l Proxy+                    (_, Left r) -> mkVariant (Label :: Label t) r Proxy+                    (Right l, Right r) -> extendVariant $ l <> r++-- * Monoid+instance (Unvariant '[Tagged t x] x, Monoid x) => Monoid (Variant '[Tagged t x]) where+    mempty = mkVariant (Label :: Label t) mempty Proxy+#if __GLASGOW_HASKELL__ <= 906+    mappend a b = case (unvariant a, unvariant b) of+                    (l, r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+#endif+++instance (Monoid x, Monoid (Variant (a ': b))) => Monoid (Variant (Tagged t x ': a ': b)) where+    mempty = extendVariant mempty+#if __GLASGOW_HASKELL__ <= 906+    mappend a b = case (splitVariant1 a, splitVariant1 b) of+                    (Left l, Left r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+                    (Left l, _) -> mkVariant (Label :: Label t) l Proxy+                    (_, Left r) -> mkVariant (Label :: Label t) r Proxy+                    (Right l, Right r) -> extendVariant $ mappend l r+#endif++-- * Projection++{- | convert a variant with more fields into one with fewer (or the same)+fields.+++>>> let ty = Proxy :: Proxy [Tagged "left" Int, Tagged "right" Int]+>>> let l = mkVariant _left 1 ty+>>> let r = mkVariant _right 2 ty+++>>> map projectVariant [l, r] :: [Maybe (Variant '[Tagged "left" Int])]+[Just V{left=1},Nothing]+++@'rearrangeVariant' = 'fromJust' . 'projectVariant'@ is one implementation+of 'rearrangeVariant', since the result can have the same fields with+a different order:++>>> let yt = Proxy :: Proxy [Tagged "right" Int, Tagged "left" Int]++>>> map projectVariant [l, r] `asTypeOf` [Just (mkVariant _left 0 yt)]+[Just V{left=1},Just V{right=2}]+++-}+class ProjectVariant x y where+    projectVariant :: Variant x -> Maybe (Variant y)++instance (ProjectVariant x ys,+          HasField t (Variant x) (Maybe y),+          HOccursNot (Label t) (LabelsOf ys),+          ty ~ Tagged t y)+  => ProjectVariant x (ty ': ys) where+    projectVariant x = y `mplus` ys+      where t = Label :: Label t+            y = (\v -> mkVariant t v Proxy) <$> x .!. t+            ys = (mty  .*.) <$> (projectVariant x :: Maybe (Variant ys))+            mty = Tagged Nothing :: Tagged t (Maybe y)++instance ProjectVariant x '[] where+    projectVariant _ = Nothing++++{- | @projectExtendVariant = fmap 'extendVariant' . 'projectVariant'@++where intermediate variant is as large as possible. Used to implement+"Data.HList.Labelable".'projected'++Note that:++>>> let r = projectExtendVariant (mkVariant1 Label 1 :: Variant '[Tagged "x" Int])+>>> r :: Maybe (Variant '[Tagged "x" Integer])+Nothing++-}+class HAllTaggedLV y => ProjectExtendVariant x y where+    projectExtendVariant :: Variant x -> Maybe (Variant y)++instance HAllTaggedLV y => ProjectExtendVariant '[] y where+    projectExtendVariant _ = Nothing++instance (lv ~ Tagged l v,+          HMemberM lv y inY,+          ProjectExtendVariant' inY lv y,+          ProjectExtendVariant xs y+      ) => ProjectExtendVariant (lv ': xs) y where+  projectExtendVariant v = case splitVariant1' v of+      Left lv -> projectExtendVariant' (Proxy :: Proxy inY) lv+      Right v' -> projectExtendVariant v'+++class ProjectExtendVariant' (inY :: Maybe [*]) lv (y :: [*]) where+    projectExtendVariant' :: Proxy inY -> lv -> Maybe (Variant y)++instance ProjectExtendVariant' Nothing lv y where+    projectExtendVariant' _ _ = Nothing++instance (MkVariant l v y, lv ~ Tagged l v) => ProjectExtendVariant' (Just t) lv y where+    projectExtendVariant' _ (Tagged v) = Just (mkVariant (Label :: Label l) v Proxy)++++class (ProjectVariant x yin,+       ProjectVariant x yout) => SplitVariant x yin yout where+    splitVariant :: Variant x -> Either (Variant yin) (Variant yout)++instance+   (-- implementation+    ProjectVariant x yin,+    ProjectVariant x yout,++    -- constraints to ensure exactly one of+    -- the uses of projectVariant gives a Just+    H2ProjectByLabels (LabelsOf yin) x xi xo,+    HRearrange (LabelsOf yin) xi yin,+    HRearrange (LabelsOf yout) xo yout,++    HLeftUnion xi xo xixo,+    HRearrange (LabelsOf x) xixo x,++    -- probably redundant+    HAllTaggedLV x, HAllTaggedLV yin, HAllTaggedLV yout) =>+  SplitVariant x yin yout where+  splitVariant x = case (projectVariant x, projectVariant x) of+   (Nothing, Just yout) -> Right yout+   (Just yin, Nothing) -> Left yin+   _ -> error "Data.HList.Variant:splitVariant impossible"++-- | @projectVariant . extendsVariant = Just@ (when the types match up)+--+-- 'extendVariant' is a special case+class (HAllTaggedLV y, HAllTaggedLV x) => ExtendsVariant x y where+    extendsVariant :: Variant x -> Variant y++instance (MkVariant l e y, le ~ Tagged l e,+          ExtendsVariant (b ': bs) y) => ExtendsVariant (le ': b ': bs) y where+    extendsVariant v = case splitVariant1 v of+        Left e -> mkVariant (Label :: Label l) (e :: e) Proxy+        Right vs -> extendsVariant vs++instance (HAllTaggedLV x, Unvariant '[le] e, MkVariant l e x,+          le ~ Tagged l e) => ExtendsVariant '[le] x where+    extendsVariant v = mkVariant (Label :: Label l) (unvariant v) Proxy+++-- | @rearrangeVariant@ is a specialization of 'extendsVariant' whose+-- result is always . see also 'rearranged'+rearrangeVariant :: (SameLength v v', ExtendsVariant v v')+      => Variant v -> Variant v'+rearrangeVariant v = extendsVariant v++instance (SameLength s a, ExtendsVariant s a,+          SameLength b t, ExtendsVariant b t) => Rearranged Variant s t a b+  where+    rearranged = iso rearrangeVariant rearrangeVariant++-- | @Prism (Record tma) (Record tmb) (Variant ta) (Variant tb)@+--+-- see 'hMaybied''+hMaybied x = prism variantToHMaybied+    (\s -> case hMaybiedToVariants s of+          [a] -> Right a+          _ -> Left (hMapR HCastF s))+    x+++data HCastF = HCastF++instance (mx ~ Maybe x,+          my ~ Maybe y,+          HCast y x) =>+  ApplyAB HCastF mx my where+    applyAB _ x = hCast =<< x++++{- | @Prism' (Record tma) (Variant ta)@++where @tma@ and @tmb@ are lists like++> tma ~ '[Tagged x (Maybe a), Tagged y (Maybe b)]+> ta  ~ '[Tagged x        a , Tagged y        b ]++If one element of the record is Just, the Variant will+contain that element. Otherwise, the prism fails.++[@Note@]++The types work out to define a prism:++@l = 'prism'' 'variantToHMaybied' ('listToMaybe' . 'hMaybiedToVariants')@++but the law: @s^?l ≡ Just a ==> l # a ≡ s@ is not followed,+because we could have:++@+  s, s2 :: Record '[Tagged "x" (Maybe Int), Tagged "y" (Maybe Char)]+  s = hBuild (Just 1) (Just '2')+  s2 = hBuild (Just 1) Nothing++  v :: Variant '[Tagged "x" Int, Tagged "y" Char]+  v = mkVariant (Label :: Label "x") 1 Proxy+@++So that @s^?l == Just v@. But @l#v == s2 /= s@, while the law+requires @l#v == s@. hMaybied avoids this problem by only+producing a value when there is only one present.++-}+hMaybied' x = simple (hMaybied (simple x))++class VariantToHMaybied v r | v -> r, r -> v where+    variantToHMaybied :: Variant v -> Record r++instance VariantToHMaybied '[] '[] where+    variantToHMaybied _ = emptyRecord++instance (VariantToHMaybied v r,+          HReplicateF nr ConstTaggedNothing () r,++          tx ~ Tagged t x,+          tmx ~ Tagged t (Maybe x))+    => VariantToHMaybied (tx ': v) (tmx ': r) where+      variantToHMaybied v = case splitVariant1 v of+            Left x -> Record+                $ HCons (Tagged (Just x))+                $ hReplicateF Proxy ConstTaggedNothing ()+            Right rest ->+                case variantToHMaybied rest of+                  Record a -> Record $ (Tagged Nothing :: Tagged t (Maybe x)) `HCons` a+          -- don't use (.*.) because we have (LabelsOf v ~ LabelsOf r), so+          -- the duplicate check (HRLabelSet) implied by (.*.) is redundant++data ConstTaggedNothing = ConstTaggedNothing+instance (y ~ Tagged t (Maybe e)) => ApplyAB ConstTaggedNothing x y where+    applyAB _ _ = Tagged Nothing++-- | Every element of the record that is Just becomes one element+-- in the resulting list. See 'hMaybied'' example types that @r@+-- and @v@ can take.+hMaybiedToVariants ::+  (HFoldr HMaybiedToVariantFs [Variant '[]] r [Variant v], -- impl+   VariantToHMaybied v r -- evidence for typechecking+  ) => Record r -> [Variant v]+hMaybiedToVariants (Record r) = hFoldr HMaybiedToVariantFs ([] :: [Variant '[]]) r++data HMaybiedToVariantFs = HMaybiedToVariantFs++instance (x ~ (Tagged t (Maybe e), [Variant v]),+          y ~ [Variant (Tagged t e ': v)],+          MkVariant t e (Tagged t e ': v))+        => ApplyAB HMaybiedToVariantFs x y where++  applyAB _ (Tagged me, v) = case me of+    Just e -> mkVariant (Label :: Label t) e Proxy : map extendVariant v+    _ -> fmap extendVariant v
+ Data/HList/broken/CHList.hs view
@@ -0,0 +1,349 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-}+++++-- XXX Updates are delayed...+-- | Potentially infinite, open, statically constrained HLists...++module CHList where++-- Nat is not strictly necessary, but good for error-checking...+-- Mapping from Nats to {HNothing,HJust x}+-- The end of the list is HNothing with the smallest index++class Nat n => CHList l n r | l n -> r where+    chel :: l -> n -> r+    chel = undefined++-- Default `cut-off' instance+instance (Nat n, TypeCast r HNothing) => CHList l n r+++-- The first two CHList++data LEmpty = LEmpty                    -- and that is it...++data L1 = L1+instance CHList L1 Z (HJust Int) where+    chel _ _ = HJust 0+instance CHList L1 (S Z) (HJust Int) where+    chel _ _ = HJust 1+++-- Convert CHList to HList, starting from the N-th element+class CHL2HL l n r | l n -> r where+    chl_to_hl_n :: l -> n -> r++instance (CHList l n el, CHL2HL (CHL2HL' l el) n r)+    => CHL2HL l n r where+    chl_to_hl_n l n = chl_to_hl_n (CHL2HL' l (chel l n)) n++data CHL2HL' l el = CHL2HL' l el++instance CHL2HL (CHL2HL' l HNothing) n HNil where+    chl_to_hl_n _ _ = HNil++instance CHL2HL l (S n) r => CHL2HL (CHL2HL' l (HJust a)) n (HCons a r) where+    chl_to_hl_n (CHL2HL' l (HJust x)) n = HCons x (chl_to_hl_n l (S n))++chl_to_hl l = chl_to_hl_n l Z++test1 = show $ chl_to_hl L1+++-- List functions++-- It is a type error to apply it to an empty list+cl_head l = fromHJust (chel l Z)++test_h1 = cl_head L1 -- 0+-- the following is a type error+-- test_h2 = cl_head LEmpty++newtype CLTail l = CLTail l+instance (Nat n, CHList l (S n) r) => CHList (CLTail l) n r where+    chel (CLTail l) n = chel l (S n)++-- ensure the list to take the tail of is non-empty+cl_tail :: CHList l Z (HJust e) => l -> CLTail l+cl_tail l = CLTail l++test_h3 = cl_head (cl_tail L1) -- 1++-- would be error: tail of empty list+-- test_t1 = cl_tail LEmpty++-- Can't take head of the empty list+-- test_h4 = cl_head (cl_tail (cl_tail L1))++data CLCons a l = CLCons a l+cl_cons = CLCons++instance CHList (CLCons a l) Z (HJust a) where+    chel (CLCons x _ ) _ = HJust x++instance (Nat n, CHList l n r) => CHList (CLCons a l) (S n) r where+    chel (CLCons _ l) (S n) = chel l n+++test_c1 = cl_head (cl_tail (cl_cons ((-2)::Int) (cl_cons ((-1)::Int) L1)))++-- and we can construct (heterogeneous) lists with the regular list API+test_c2 = cl_head (cl_tail (cl_cons () (cl_cons True LEmpty)))++test_c3 = show $ chl_to_hl $ cl_cons () L1+++-- Mapping+data CLMap f l = CLMap f l+cl_map = CLMap++instance (Nat n, CHList l n r', Apply (HJust f) r' r)+    => CHList (CLMap f l) n r where+    chel (CLMap f l) n = apply (HJust f) (chel l n)++instance Apply (HJust f) HNothing HNothing where+    apply _ _ = HNothing+instance Apply f x r => Apply (HJust f) (HJust x) (HJust r) where+    apply (HJust f) (HJust x) = HJust (apply f x)+++-- Looks just like the regular map application...+test_m1 = cl_map (succ :: Int->Int) L1+test_m2 = show $ chl_to_hl test_m1++-- Notice the similarity with the following. The difference is the case of l1!+test_m1' = map (succ :: Int->Int) l1+    where l1 = [0,1]++-- Folding+data CLFold f z = CLFold f z+cl_fold f z l = apply (CLFold f z) (l,Z,chel l Z)+++instance Apply (CLFold f z) (l,n,HNothing) z where+    apply (CLFold _ z) _ = z++instance (Apply f (x,z') r, CHList l (S n) e,+          Apply (CLFold f z) (l,(S n),e) z', Nat n)+    => Apply (CLFold f z) (l, n, HJust x) r where+    apply op@(CLFold f z) (l,n,HJust x) =+        apply f (x,apply op (l,S n,chel l (S n)))+++test_f1 = cl_fold (uncurry ((+)::Int->Int->Int)) (0::Int) L1+++-- Taking+data CLTake n l = CLTake n l+cl_take = CLTake+++data PLEQ = PLEQ+-- PLEQ x y ==> HTrue if x <= y+instance Apply PLEQ (Z,Z) HTrue+instance Apply PLEQ (Z,S y) HTrue+instance Apply PLEQ (S x,Z) HFalse+instance Apply PLEQ (x,y) r => Apply PLEQ (S x,S y) r++data IF = IF+instance Apply IF (HTrue,x,y) x where+    apply _ (_,x,y) = x+instance Apply IF (HFalse,x,y) y where+    apply _ (_,x,y) = y+++instance (Apply PLEQ (S m,n) bf, CHList l m x, Apply IF (bf,x,HNothing) r)+    => CHList (CLTake n l) m r where+    chel (CLTake n l) m = apply IF (undefined::bf, chel l m, HNothing)+++-- Infinite lists++data LNats = LNats  -- lists of successive numerals+instance Nat n => CHList LNats n (HJust n) where+    chel _ n = HJust n++test_nat1 = cl_head (cl_tail LNats)+test_nat2 = cl_take four LNats+test_nat3 = show $ chl_to_hl test_nat2+++data Add = Add+instance Nat n => Apply Add (Z,n) n+instance (Nat n, Nat m, Apply Add (n,m) r) => Apply Add (S n, m) (S r)++-- Other infinite lists can be defined by mapping over LNats++data Mul2 = Mul2+instance (Nat n, Apply Add (n,n) r) => Apply Mul2 n r++l2nats = cl_map Mul2 LNats -- double Nats+test_nn = show $ chl_to_hl $ cl_take four l2nats+++data LFibs = LFibs  -- lists of Fibonacci numbers+instance CHList LFibs Z (HJust (S Z))+instance CHList LFibs (S Z) (HJust (S Z))+instance (Nat n, CHList LFibs (S n) (HJust e1), CHList LFibs n (HJust e2),+          Apply Add (e1,e2) r)+    => CHList LFibs (S (S n)) (HJust r)++test_fib = show $ chl_to_hl $ cl_take five LFibs+-- "HCons S Z (HCons S Z (HCons S S Z (HCons S S S Z +--       (HCons S S S S S Z HNil))))"++++-- Infinitely extensible lists++data LCyc = LCyc++instance (Nat n, CHList LCyc n r) => CHList LCyc (S (S n)) r where+    chel l (S (S n)) = chel l n++instance CHList LCyc Z (HJust ()) where+    chel _ _ = HJust ()++test_cyc = show $ chl_to_hl $ cl_take five LCyc++-- one instance: "HNil"+-- two instances: "HCons () HNil"++{-+instance CHList LCyc (S Z) (HJust Bool) where+    chel _ _ = HJust True+						 +-- "HCons () (HCons True (HCons () (HCons True (HCons () HNil))))"++instance CHList LCyc (S (S Z)) (HJust Bool) where+    chel _ _ = HJust False++-- "HCons () (HCons True (HCons False (HCons True (HCons False HNil))))"++instance CHList LCyc (S (S (S Z))) (HJust Char) where+    chel _ _ = HJust 'a'++test_cyc1 = show $ chl_to_hl $ cl_take seven LCyc+-}+++-- test_cyc1+-- "HCons () (HCons True (HCons False (HCons 'a' (HCons False (HCons 'a' (HCons False HNil))))))"+++-- Statically constrained lists+-- A constraint is a binary predicate, applied to two consecutive+-- CHList elements. The constraint is satisfied if the predicate+-- returns HTrue+-- For simplicity, we declare a class of lists whose elements are+-- non-decreasing numerals++data CK l = CK l++class (Nat n, Apply (CK l) (n,r) HTrue) => C1 l n r | l n -> r where+    chel1 :: l -> n -> r+    chel1 = undefined+-- Default `cut-off' instance+instance (Nat n, TypeCast r HNothing, Apply (CK l) (n, r) HTrue) => C1 l n r++instance Apply (CK l) (Z,r) HTrue+instance Apply (CK l) (S n,HNothing) HTrue+instance (C1 l n (HJust ep), Apply PLEQ (ep,e) r)+    => Apply (CK l) (S n,HJust e) r+++data LC1 = LC1++instance C1 LC1 Z (HJust Z)+instance C1 LC1 (S Z) (HJust Z)+instance C1 LC1 (S (S Z)) (HJust (S (S (S Z))))++-- The following is the type error+-- instance C1 LC1 (S (S (S Z))) (HJust Z)++data LC2 = LC2+instance C1 LC2 Z (HJust Z)+          -- this constraint suggested by the typechecker+instance (Apply PLEQ (r, S (S r)) HTrue,+          C1 LC2 n (HJust r))+    => C1 LC2 (S n) (HJust (S (S r)))+++newtype C1toCL cl = C1toCL cl++instance C1 cl n r => CHList (C1toCL cl) n r where+    chel (C1toCL l) n = chel1 l n++test_cl1 = show $ chl_to_hl $ C1toCL LC1++test_cl2 = show $ chl_to_hl $ cl_take five (C1toCL LC2)++++++-- A data type of heterogenous lists with whose elements are successively+-- increasing type-level naturals. These lists can be infinite.+-- In this simple case, we can get by without all the above machinery.+-- However, if the static constraint is non-decreasing order of elements,+-- we no longer able to express it that simply.+data SeqI a = ConsI a (SeqI (S a)) | NilI++seqi1 = ConsI Z (ConsI (S Z) NilI)++-- seqi2 = ConsI Z (ConsI Z NilI)++seqi_inf :: n -> SeqI n+seqi_inf n = ConsI n (seqi_inf (S n))++seqi3 = seqi_inf (S Z)++++-- The standard HList stuff, included here for completeness++data Z = Z+newtype S a = S a++instance Show Z where show _ = "Z"+instance Show n => Show (S n) where show _ = "S " ++ show (undefined::n)++class Nat a                             -- Kind of natural numbers+instance Nat Z+instance Nat a => Nat (S a)++four = S $ S $ S $ S Z                  -- A few sample numbers+five = S $ four+seven = S $ S $ five+++data HTrue+data HFalse++data HNothing = HNothing+newtype HJust x = HJust x+fromHJust (HJust x) = x                 -- this is the total function!++data HNil = HNil deriving Show+data HCons a b = HCons a b deriving Show+++class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b+class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b+class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b+instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x+instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''+instance TypeCast'' () a a where typeCast'' _ x  = x++-- A heterogeneous apply operator++class Apply f a r | f a -> r where+  apply :: f -> a -> r+  apply = undefined++-- Normal function application+instance Apply (x -> y) x y where+  apply f x = f x
+ Data/HList/broken/ConsUnion.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}++-- Updates delayed: need wildcard type comparison, to be implemented later++{- |++-- (C) 2004-2007, Oleg Kiselyov & Ralf Laemmel++Creating a regular (homogeneous) Haskell list by consing values of+generally different types. The consing operation builds a union as it+adds more elements to the list.++The operations consEither, nilEither are generalizations of ((:),[]).+In fact, the former reduce to the latter in the case of homogeneous+lists.++Our building of unions is efficient: if the new element is already+in the union, we inject it into the existing uniuon rather than+extend the union: see the tests te5-te7 below.++Future work, quoting Ralf:+``It looks like consEither is the deforested version of an+operation to take an HList and to return a non-HList. Probably both+are worth having, and the inverse operation of taking a homogenous+list with potentially an Either on the element type to return a plain+HList. This could be a new theme in the HList library -- all around+heterogeneous/homogeneous mediation.''++-}++module Data.HList.ConsUnion (NilEither, nilEither,+                  consEither,++                  -- Union injection/projection+                  TSame, TNone, TContains(..),+                  tsearch,+                  downCast ) where++import Data.HList.FakePrelude (HNothing(..), HJust(..))+import Data.HList.Record+import Data.HList.RecordAdv++-- List constructors that union as well++data NilEither+nilEither :: NilEither+nilEither = undefined :: NilEither++class ConsEither h t l | h t -> l+ where+  consEither :: h -> t -> l++instance ConsEither e  NilEither [e]+ where+  consEither h _ = [h]++instance (TypeEqInc eu e f, ConsEither' f e eu l)+    => ConsEither e [eu] l where+  consEither h t = consEither' (tsearch (undefined::eu) (undefined::e)) h t+++class ConsEither' f e eu l | f e eu -> l where+    consEither' :: f -> e -> [eu] -> l++instance ConsEither' TNone e eu [Either e eu] where+    consEither' _ h t = Left h : map Right t++instance ConsEither' TSame e e [e] where+    consEither' _ h t = h : t++instance ConsEither' (TContains e eu) e eu [eu] where+    consEither' (TContains inj _) h t = inj h : t+++-- Compare the type t with the type tu and return:+--  TSame -- if t = tu+--  TContains t tu -- if tu is the type Either tul tur and+--                      either tul or tur is or includes t+--  TNone -- otherwise++data TSame                              -- ^ outcomes of the comparison+data TContains t tu = TContains (t->tu)       -- injection function+                                (tu->Maybe t) -- projection function+data TNone++class TypeEqInc tu t res | tu t -> res where+    tsearch :: tu -> t -> res+    tsearch = undefined+++instance TypeEqInc tu tu TSame+instance (IsEither tu atu, TypeEqInc' atu t res)+    => TypeEqInc tu t res+  where+    tsearch _ = tsearch' (undefined::atu)++class TypeEqInc' atu t res | atu t -> res where+    tsearch' :: atu -> t -> res+    tsearch' = undefined++-- instance TypeEqInc' (TOther tu)  t TNone+instance (TypeEqInc tul t atul, TypeEqInc tur t atur,+          TypeEqInc'' atul atur tul tur res)+    => TypeEqInc' (Either tul tur) t res where+    tsearch' _ t = tsearch'' (tsearch (undefined::tul) t)+                               (tsearch (undefined::tur) t)+                               (undefined::tul)+                               (undefined::tur)++class TypeEqInc'' atul atur tul tur res | atul atur tul tur -> res where+    tsearch'' :: atul -> atur -> tul -> tur -> res+    tsearch'' = undefined++instance TypeEqInc'' TNone TNone tul tur TNone++instance TypeEqInc'' TSame TNone t tur (TContains t (Either t tur)) where+    tsearch'' _ _ _ _ = TContains Left (either Just (const Nothing))++instance TypeEqInc'' TNone TSame tul t (TContains t (Either tul t)) where+    tsearch'' _ _ _ _ = TContains Right (either (const Nothing) Just)++instance TypeEqInc'' (TContains t tul) TNone tul tur+    (TContains t (Either tul tur)) where+    tsearch'' (TContains inj prj)  _ _ _ =+        TContains (Left . inj) (either prj (const Nothing))++instance TypeEqInc'' TNone (TContains t tur) tul tur+    (TContains t (Either tul tur)) where+    tsearch'' _ (TContains inj prj) _ _ =+        TContains (Right . inj) (either (const Nothing) prj)++++instance (IsRecord tu atu, IsRecord t at, TypeEqIncR atu at res)+    => TypeEqInc' (TOther tu) t res where+    tsearch' _ _ = tsearchR (undefined::atu) (undefined::at)+++class TypeEqIncR atu at res | atu at -> res where+    tsearchR :: atu -> at -> res+    tsearchR = undefined++instance TypeEqIncR (Record ru) (TOther b) TNone+instance TypeEqIncR (TOther a)  b TNone+++instance (RecordEquiv' (Record ru -> r12)+                                   (Record r -> r21)+                                   b,+                      NarrowM r ru r21,+                      NarrowM ru r r12,+          RecordEquiv ru r b, TypeEqIncR' b res)+  -- For some reason the compiler needs all the above constraints, rather+  -- than the two below. Why does it need to `inline' the+  -- RecordEquiv ru r b constraint? Seems like a bug...+  -- (RecordEquiv ru r b, TypeEqIncR' b res)+    => TypeEqIncR (Record ru) (Record r) res where+    tsearchR ru r = tsearchR' (equivR ru r)++class TypeEqIncR' pjs res | pjs -> res where+    tsearchR' :: pjs -> res+    tsearchR' = undefined++instance TypeEqIncR' HNothing TNone++instance TypeEqIncR' (HJust (ru->r,r->ru)) (TContains r ru) where+    tsearchR' (HJust (pj,ij)) = TContains ij (Just . pj)++++-- Check to see if t is an Either type or a record type+data TOther t+class IsEither t res | t -> res+instance IsEither (Either t1 t2) (Either t1 t2)+instance res ~ (TOther t) => IsEither t res++class IsRecord t res | t -> res+instance IsRecord (Record t) (Record t)+instance res ~ (TOther t) => IsRecord t res++-- A few tests of consEither++-- consEither should act as a regular cons for homogeneous lists+te1 = consEither () nilEither+te2 = consEither () (consEither () nilEither)+-- [(),()]++te3 = consEither True (consEither () nilEither)+-- [Left True,Right ()]++te4 = consEither 'a' (consEither True (consEither () nilEither))+-- [Left 'a',Right (Left True),Right (Right ())]++te5 = consEither () (consEither True (consEither () nilEither))+-- [Right (),Left True,Right ()]++te6 = consEither 'a' (consEither True (consEither False nilEither))+-- [Left 'a',Right True,Right False]++te7 = consEither True (consEither True (consEither () nilEither))+-- [Left True,Left True,Right ()]+++-- |+-- Down-cast a value of a union type to a summand type.+-- Make sure that the summand type occurs once at least.++class DownCast u s+  where+    downCast :: u -> Maybe s++instance (TypeEqInc u s au, DownCast' au u s) => DownCast u s where+    downCast = downCast' (tsearch (undefined::u) (undefined::s))+++class DownCast' au u s | au s -> u where+    downCast' :: au -> u -> Maybe s++instance DownCast' TSame s s where+    downCast' _ = Just++instance DownCast' (TContains s u) u s where+    downCast' (TContains _ prj) = prj+++--+-- The following is deliberately omitted. That means attempting to+-- project a type that is not in the union should give a type error.+--+-- instance DownCast' TNone s s+--+
+ Data/HList/broken/Label1.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++{- |+   The HList library++   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A model of label as needed for extensible records.++   Record labels are simply type-level naturals.+   This models is as simple and as portable as it could be.+-}++module Data.HList.Label1 where++import Data.HList.FakePrelude hiding (Label(..))+import Data.HList.Record (ShowLabel(..))+++-- | Labels are type-level naturals++newtype Label x = Label x deriving Show+++-- | Public constructors for labels++label :: HNat n => n -> Label n+label =  Label+++-- | Construct the first label+firstLabel :: Label 'HZero+firstLabel = label hZero+++-- | Construct the next label+nextLabel :: Label t -> Label ('HSucc t)+nextLabel (Label n) = label (hSucc n)+++-- | Equality on labels++instance HEq n n' b+      => HEq (Label n) (Label n') b+++-- | Show label++instance Show n => ShowLabel (Label n)+ where+  showLabel (Label n) = show n
+ Data/HList/broken/Label2.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, EmptyDataDecls #-}++{- |+   The HList library++   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A model of labels as needed for extensible records. As before,+   all the information about labels is recorded in their type, so+   the labels of records may be purely phantom. In general,+   Labels are exclusively type-level entities and have no run-time+   representation.++   Record labels are triplets of type-level naturals, namespace,+   and description. The namespace part helps avoid confusions between+   labels from different Haskell modules. The description is+   an arbitrary nullary type constructor.++   For the sake of printing, the namespace part and the description+   are required to be the instance of Show. One must make sure that+   the show functions does not examine the value, as descr is purely phantom.+   Here's an example of the good Label description:++   >     data MyLabelDescr; instance Show MyLabelDescr where show _ = "descr"++   which obviously can be automated with Template Haskell.++   This model requires all labels in a record to inhabit the same namespace.+-}++module Data.HList.Label2 where++import Data.HList.FakePrelude+import Data.HList.Record (ShowLabel(..))+++-- | Labels are type-level naturals++data Label x ns desc  -- labels are exclusively type-level entities+++-- | Construct the first label++firstLabel :: ns -> desc -> Label HZero ns desc+firstLabel = undefined+++-- | Construct the next label+nextLabel :: Label x ns desc -> desc' -> Label (HSucc x) ns desc'+nextLabel = undefined+++-- | Equality on labels (descriptions are ignored)++instance HEq x x' b+      => HEq (Label x ns desc1) (Label x' ns desc2) b+++-- | Show label++instance (HNat x, Show desc) => ShowLabel (Label x ns desc) where+  showLabel = show . getd+      where getd :: Label x ns desc -> desc+            getd = undefined++instance (HNat x, HNat2Integral x,Show ns) => Show (Label x ns desc) where+  show l = unwords ["L",show ((hNat2Integral x)::Integer), show ns]+      where geti :: Label x ns desc -> (x,ns) -- for the sake of Hugs+            geti = undefined+            (x,ns) = geti l
+ Data/HList/broken/Label4.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, EmptyDataDecls #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Yet another model of labels.++   Labels are type proxies.++   See "Data.HList.MakeLabels"+-}++module Data.HList.Label4 where++import Data.Typeable+import Data.Char++import Data.HList.FakePrelude+import Data.HList.Record+++-- | Equality on labels++-- instance TypeEq x y b => HEq (Proxy x) (Proxy y) b++++-- | Show label++instance Typeable x => ShowLabel (Proxy x)+ where+  showLabel = (\(x:xs) -> toLower x:xs)+            . reverse+            . takeWhile (not . (==) '.')+            . reverse+            . show+{-+            . tyConString+            . typeRepTyCon+-}+            . typeOf+            . unProxy
+ Data/HList/broken/Lazy.hs view
@@ -0,0 +1,243 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}++-- |+-- Lazy HLists: potentially infinite heterogeneous streams...+-- Based on the suggestion by Chung-chieh Shan, posted on the+-- Haskell mailing list on Sun Oct 29 13:51:58 EST 2006++module Data.HList.HLazy where++import Data.HList.FakePrelude+import Data.HList.HListPrelude++-- our dream is to write something similar to+fib = 1 : 1 : zipWith (+) fib (tail fib)+++-- The denotation of the application of the `function' f to the+-- the argument x. The function is meant to be any Apply-able thing.+data Thunk f x = Thunk f x++class Force thunk result | thunk -> result where+    force :: thunk -> result++instance Force HNil HNil where+    force = id++instance Force (HCons a b) (HCons a b) where+    force = id++instance Apply f x r => Force (Thunk f x) r where+    force (Thunk f x) = apply f x+++instance HList (Thunk g x)++-- Take the prefix of a stream, forcing thunks if needed.+-- We need this function for the sake of `printing' streams, at least++newtype HTake n = HTake n++instance Apply (HTake HZero) l HNil where+    apply _ _ = HNil+instance Apply (HTake (HSucc n)) HNil HNil where+    apply _ _ = HNil+instance Apply (HTake n) b b'+    => Apply (HTake (HSucc n)) (HCons a b) (HCons a b') where+    apply _ (HCons a b) =+        HCons a (apply (HTake (undefined::n)) b)+instance (Apply g x l, Apply (HTake (HSucc n)) l r)+    => Apply (HTake (HSucc n)) (Thunk g x) r where+    apply n (Thunk g x) = apply n (apply g x)++htake n l = apply (HTake n) l+++htail :: (Force l (HCons a b)) => l -> b+htail l = b where HCons _ b = force l++-- First stream: all zeros+-- Note the mutual dependency between a term and an instance++data LZeros+lzeros = Thunk (undefined::LZeros) ()++instance Apply LZeros () (HCons HZero (Thunk LZeros ())) where+    apply _ _ = HCons hZero lzeros+++tzeros = htake four lzeros+{-+*HLazy> tzeros+HCons HZero (HCons HZero (HCons HZero (HCons HZero HNil)))+-}+++-- Second stream: of natural numbers++data LNats+lnats = Thunk (undefined::LNats)++instance HNat n => Apply LNats n (HCons n (Thunk LNats (HSucc n))) where+    apply _ n = HCons n (lnats (hSucc n))++tnats = htake five . htail $ lnats hZero+{-+ *Data.HList.HLazy> tnats+  HCons HSucc HZero (HCons HSucc (HSucc HZero) +    (HCons HSucc (HSucc (HSucc HZero)) +      (HCons HSucc (HSucc (HSucc (HSucc HZero))) +        (HCons HSucc (HSucc (HSucc (HSucc (HSucc HZero)))) HNil))))+-}+++-- Extend HFold, HMap and HZip for the Lazy lists.+-- We don't need to re-write these classes. We merely need to add+-- an instance that accounts for the Thunk++instance (Apply g x l, HFoldr f v l r)+    => HFoldr f v (Thunk g x) r where+  hFoldr f v (Thunk g x) = hFoldr f v (apply g x)+++-- We make our map lazy: when we map over thunk, we make a thunk+newtype HMapC f = HMapC f++instance HMap f (Thunk g x) (Thunk (HMapC f) (Thunk g x)) where+  hMap f x = Thunk (HMapC f) x++instance (Force x l, HMap f l r) => Apply (HMapC f) x r where+    apply (HMapC f) l = hMap f (force l)++++data Add = Add+instance HNat n => Apply Add (HZero,n) n+instance (HNat n, HNat m, Apply Add (n,m) r)+    => Apply Add (HSucc n, m) (HSucc r)++-- We obtain the list of ones by incrementing the list of zeros+data Incr = Incr+instance Apply Incr n (HSucc n)++lones = hMap Incr lzeros++tones = htake five lones+{-+ *Data.HList.HLazy> tones+  HCons HSucc HZero (HCons HSucc HZero +   (HCons HSucc HZero (HCons HSucc HZero (HCons HSucc HZero HNil))))+-}++-- and the list of evens by doubling the list of naturals++data Twice = Twice+instance Apply Add (n,n) r => Apply Twice n r++levens = hMap Twice (lnats hZero)+tevens = htake five levens+{-+ *Data.HList.HLazy> tevens+ HCons HZero (HCons HSucc (HSucc HZero) +    (HCons HSucc (HSucc (HSucc (HSucc HZero))) +     (HCons HSucc (HSucc (HSucc (HSucc (HSucc (HSucc HZero)))))+      (HCons HSucc (HSucc (HSucc (HSucc (HSucc (HSucc +              (HSucc (HSucc HZero))))))) HNil))))+-}++++-- The class Zip in Zip.hs was made to handle lists of the same length+-- Here, we define a bit general one++class LZip l1 l2 l3 | l1 l2 -> l3 where+    lzip :: l1 -> l2 -> l3++instance LZip HNil l2 HNil where+    lzip _ _ = HNil++instance LZip (HCons a b) HNil HNil where+    lzip _ = id++instance LZip (Thunk a b) HNil HNil where+    lzip _ = id++instance LZip tx ty l+    => LZip (HCons hx tx) (HCons hy ty) (HCons (hx,hy) l) where+    lzip (HCons hx tx) (HCons hy ty) = HCons (hx,hy) (lzip tx ty)++data LZipC = LZipC+instance LZip (Thunk g x) (HCons a b)+              (Thunk LZipC ((Thunk g x),(HCons a b))) where+    lzip l1 l2 = Thunk LZipC (l1,l2)++instance LZip (HCons a b) (Thunk g x)+              (Thunk LZipC ((HCons a b),(Thunk g x))) where+    lzip l1 l2 = Thunk LZipC (l1,l2)++instance LZip (Thunk a b) (Thunk g x)+              (Thunk LZipC ((Thunk a b),(Thunk g x))) where+    lzip l1 l2 = Thunk LZipC (l1,l2)++instance (Force l1 r1, Force l2 r2, LZip r1 r2 r) =>+    Apply LZipC (l1,l2) r where+    apply _ (l1,l2) = lzip (force l1) (force l2)++++-- All is ready for our Fibonacci. Of course the simplest way to write+-- Fibonacci is along the lines of LNats above: just carry the state in+-- the thunk. The way given below is more laborous -- but cooler.++data LFibs = LFibs++lfibs = HCons hone (HCons hone (Thunk LFibs ()))++lfibs' = hMap Add (lzip lfibs (htail lfibs))++instance Apply LFibs ()+    -- the latter type is the type of lfibs'+    -- I simply did ":t lfibs'" and cut and pasted the result from+    -- one Emacs buffer (GHCi prompt) to the other.+    (HCons (HSucc (HSucc HZero))+     (Thunk (HMapC Add)+      (Thunk LZipC+       (HCons (HSucc HZero) (Thunk LFibs ()), Thunk LFibs ()))))+ where+    apply _ _ = lfibs'+++tfibs = htake seven lfibs++{-+  *Data.HList.HLazy> tfibs+  HCons HSucc HZero +   (HCons HSucc HZero +    (HCons HSucc (HSucc HZero) +      (HCons HSucc (HSucc (HSucc HZero))+        (HCons HSucc (HSucc (HSucc (HSucc (HSucc HZero))))+          (HCons HSucc (HSucc (HSucc (HSucc (HSucc +                              (HSucc (HSucc (HSucc HZero)))))))+            (HCons HSucc (HSucc (HSucc (HSucc (HSucc (HSucc +                         (HSucc (HSucc (HSucc (HSucc (HSucc +                         (HSucc (HSucc HZero)))))))))))) HNil))))))+-}++++hone = hSucc hZero+four :: HSucc (HSucc (HSucc (HSucc HZero)))     -- A few sample numbers+four = undefined++-- five :: HSucc (HSucc (HSucc (HSucc (HSucc HZero)))f)our = undefined+five = hSucc four+seven = hSucc $ hSucc $ five+++-- We could also use something like the following+newtype LFibs' = LFibs' (HCons (HSucc HZero) (Thunk LFibs' ()))++-- however, the Apply instance for that would be just the same as above,+-- so there is no much gain...+
+ Data/HList/broken/RecordAdv.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Extensible records -- advanced operations+   These operations that (may) require GHC++   See "Data.HList.Record" for the base module.+-}++module Data.HList.RecordAdv where++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import Data.HList.HArray+import Data.HList.Record+import Data.HList.HList+import Data.Typeable++-- --------------------------------------------------------------------------++-- | A variation on update.+--+-- Replace a proxy by a value of the proxied type.+-- The signature is inferred+hUnproxyLabel l v r = hUpdateAtLabel l v r+ where+  tpe :: a -> Proxy a -> ()+  tpe _ _ = ()+  _ = tpe v (hLookupByLabel l r)+++infixr 2 .^.+{-|+  This is a variation on updating, so use the same fixity as (.\@.).+-}+f@(Tagged v) .^. r = hUnproxyLabel (labelLVPair f) v r++-- --------------------------------------------------------------------------++-- | Test for values; refuse proxies++hasNoProxies :: HasNoProxies r+             => Record r -> ()+hasNoProxies = const ()+++data ProxyFound x+class HasNoProxies (l :: [*])+instance HasNoProxies '[]+instance Fail (ProxyFound x) => HasNoProxies (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+--+-- First is the `monadic' version, which returns the `failure indictator'+-- (HNothing) if the narrowing fails because the source does not have+-- all the fields for the target.+class  NarrowM a b res | a b -> res where+    narrowM :: Record a -> Record b -> res++instance res ~ HJust (Record '[]) => NarrowM a '[] res where++    narrowM _ _ = HJust emptyRecord++instance (H2ProjectByLabels (l ': '[]) a rin rout,+          NarrowM' rin rout b res)+    => 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++-- | could be changed to type family+class  NarrowM' rin rout b res | rin rout b -> res where+    narrowM' :: Record rin -> Record rout -> Record b -> res++instance NarrowM' '[] rout b HNothing where+    narrowM' _ _ _ = HNothing++instance (NarrowM rout b res',+          NarrowM'' f res' res)+    => NarrowM' (f ': '[]) rout b res where+    narrowM' (Record (f `HCons` HNil)) rout b =+        narrowM'' f (narrowM rout b)++class  NarrowM'' f r r' | f r -> r' where+    narrowM'' :: f -> r -> r'++instance NarrowM'' f HNothing HNothing where+    narrowM'' _ _ = HNothing++instance NarrowM'' f (HJust (Record r)) (HJust (Record (f ': r))) where+    narrowM'' f (HJust (Record r)) = HJust (Record (HCons f r))+++class  Narrow a b+ where narrow :: Record a -> Record b++instance Narrow a '[]+ where   narrow _ = emptyRecord++instance ( Narrow rout 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+        (HCons f HNil,rout) -> let (Record r')    = narrow (Record rout)+            in Record (HCons f r')+++-- --------------------------------------------------------------------------++-- | Narrow two records to their least-upper bound++class LubNarrow (a :: [*]) (b :: [*]) (c :: [*]) | a b -> c+ where+  lubNarrow :: Record a -> Record b -> (Record c, Record c)++instance ( HTIntersect (LabelsOf a) (LabelsOf b) lc+         , H2ProjectByLabels lc a c aout+         , H2ProjectByLabels lc b c bout+         , HRLabelSet c+         )+      => LubNarrow a b c+ where++ lubNarrow ra@(Record _) rb@(Record _) =+     ( hProjectByLabels (Proxy::Proxy lc) ra+     , hProjectByLabels (Proxy::Proxy lc) rb+     )+++-- --------------------------------------------------------------------------++-- | List constructors that also LUB together++{-+data NilLub+nilLub :: NilLub+nilLub = undefined++class ConsLub h t l | h t -> l+ where+  consLub :: h -> t -> l++instance ConsLub e  NilLub [e]+ where+  consLub h _ = [h]++instance LubNarrow e0 e1 e2 => ConsLub e0 [e1] [e2]+ where+  consLub h t = fst (head z) : map snd (tail z)+   where+    z = map (lubNarrow h) (undefined:t)+++-- --------------------------------------------------------------------------++-- | Extension of lubNarrow to a heterogeneous list++class HLub l e | l -> e+ where+  hLub :: HList l -> [e]++instance ( LubNarrow h h' e+         )+      => HLub [h,h'] e+ where+  hLub (HCons h (HCons h' _)) = [fst ee, snd ee]+   where+    ee = lubNarrow h h'++instance ( HLub (h ': h'' ': t) e'+         , HLub (h' ': h'' ': t) e''+         , LubNarrow e' e'' e+         , HLub (e ': h'' ': t) e+         )+      => HLub (h ': h' ': h'' ': t) e+ where+  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+--+-- Decide if two records r1 and r2 are identical or differ only in the order+-- of their fields.+--+-- If the two record types are indeed equivalent, return the witness of+-- their equivalence, (HJust (r1->r2,r2->r1)). If they are not equivalent,+-- return HNothing+--+-- The function equivR does not examine the values of its arguments:+-- it needs only their types.+--+--+-- The algorithm is simple: two records are equivalent if one can be narrowed+-- to the other, and vice versa. The narrowing coercions are the desired+-- witnesses.+--+-- The obvious optimization is to check first if two records are of the same+-- type. That requires TypeEq however. Perhaps we shouldn't use it here.+-- Use of the record narrowing tacitly assumes that the label of a record+-- 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 where+    equivR :: r1 -> r2 -> res+++instance (HEq r1 r2 b, RecordEquiv' b r1 r2 res)+    => RecordEquiv r1 r2 res where+    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+    equivR' _ _ _ = HJust (id,id)++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' (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 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++-- r2 has something that r1 doesn't+instance RecordEquiv' False (r1->HNothing) pj2 HNothing where+    equivR' _ _ _ = HNothing++-- r1 is a strict superset of r2+instance RecordEquiv' False (r1->HJust r2) (r2->HNothing) HNothing where+    equivR' _ _ _ = HNothing+++-- --------------------------------------------------------------------------+-- * Typeable instances+-- TODO: see Data.HList.Data++
+ Data/HList/broken/RecordD.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,+  UndecidableInstances #-}++{- |+Yet another representation of records: records as TIC (type-indexed+collections), or, to be precise, records are lists of objects+that support the 'Fieldish' interface. So, we can build records like that++> data Name = Name String String+> newtype Salary = S Float+> data Dept = D String Int+> person = (Name "Joe" "Doe") .*. (S 1000) .*. (Dept "CIO" 123) .*. emptyRec++-}++module RecordD where++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import qualified Data.HList.Record+import Data.HList.Record (HLabelSet, HasField(..))++-- for the test+import Data.HList.TypeEqO++instance (HBool b, TypeEq x y b) => HEq x y b++-- | Define the interface of fields: basically a thing with a label+-- and injection and projection methods+class Fieldish l v | l -> v where+    fromField :: l -> v+    toField :: v -> l++newtype Record r = Record r+++-- | Build a record: a record is an HList of data items, provided+--+-- (1) the types of the data items are unique+--+-- (2) each item satsifies the interface 'Fieldish'++mkRecord :: (HLabelSet r, AllFieldish r)  => r -> Record r+mkRecord = Record++++-- | Build an empty record++emptyRecord = mkRecord HNil+++-- | make sure that all elements of an HList are Fieldish+class AllFieldish r+instance AllFieldish HNil+instance (Fieldish e v, AllFieldish r) => AllFieldish (HCons e r)++-- --------------------------------------------------------------------------++-- * Show++-- | A Show instance to appeal to normal records. Assume each Fieldish+-- is showable++instance ShowComponents r => Show (Record r)+ where+  show (Record r) =  "Record{"+                  ++ showComponents "" r+                  ++ "}"++class ShowComponents l+ where+  showComponents :: String -> l -> String++instance ShowComponents HNil+ where+  showComponents _ HNil = ""++instance ( Show f, ShowComponents r )+      =>   ShowComponents (HCons f r)+ where+  showComponents comma (HCons f r)+     =  comma+     ++ show f+     ++ showComponents "," r+++-- --------------------------------------------------------------------------+-- * Extension for records++instance (AllFieldish (HCons f r), HLabelSet (HCons f r))+    => HExtend f (Record r) (Record (HCons f r))+ where+  hExtend f (Record r) = mkRecord (HCons f r)++-- --------------------------------------------------------------------------+-- Record concatenation++instance ( HLabelSet r''+         , AllFieldish r''+         , HAppend r r' r''+         )+    => HAppend (Record r) (Record r') (Record r'')+ where+  hAppend (Record r) (Record r') = mkRecord (hAppend r r')+++-- --------------------------------------------------------------------------+-- * Lookup operation++instance (HEq l l' b, HasField' b l (HCons l' r) v)+    => HasField l (Record (HCons l' r)) v where+    hLookupByLabel l (Record r@(HCons f' _)) = hLookupByLabel' (hEq l f') l r++class HasField' b l r v | b l r -> v where+    hLookupByLabel':: b -> l -> r -> v++instance Fieldish l v => HasField' HTrue l (HCons l r) v where+    hLookupByLabel' _ _ (HCons f _) = fromField f+instance HasField l (Record r) v => HasField' HFalse l (HCons fld r) v where+    hLookupByLabel' _ l (HCons _ r) = hLookupByLabel l (Record r)+++-- some tests+data Name      = Name String String deriving Show+newtype Salary = S Float deriving Show+data Dept      = D String Int deriving Show++-- could be derived automatically, like Typeable...+instance Fieldish Name (String,String) where+    fromField (Name s1 s2) = (s1,s2)+instance Fieldish Salary Float where+    fromField (S n) = n+instance Fieldish Dept (String,Int) where+    fromField (D s n) = (s,n)++infixr 2 .*.+(.*.) :: HExtend e l l' => e -> l -> l'+(.*.) =  hExtend+infixr 3 .!.+r .!. l =  hLookupByLabel l r++person = (Name "Joe" "Doe") .*. (S 1000) .*. (D "CIO" 123) .*. emptyRecord++test1 = show person+-- "Record{Name \"Joe\" \"Doe\",S 1000.0,D \"CIO\" 123}"+-- only the type of the label matters, not the contents+test2 = person .!. (Name undefined undefined)+-- ("Joe","Doe")+test3 = person .!. (undefined::Salary)+-- 1000.0+test5 = person .!. (D "xxx" 111)+-- ("CIO",123)
+ 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
@@ -0,0 +1,216 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts,+  FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+   The HList library++   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Extensible records: labels are phantom, so at run-time, the record+   is just a heterogenous list of field values.++   This sort of record is generalizable to `tables' (which are, at+   run-time, a list or a map containing the heterogenous lists+   of field values).++   The are different models of labels that go with this module;+   see the files Label?.hs.+-}++module Data.HList.RecordP where++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import Data.HList.HList+import Data.HList.Record+import Data.HList.HArray++-- --------------------------------------------------------------------------+-- Record types as Phantom labels with values++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 :: (SameLength ls vs, HLabelSet ls) => proxy ls -> HList vs -> RecordP ls vs+mkRecordP _ vs = RecordP vs++-- Build an empty record+emptyRecordP :: RecordP ('[]) ('[])+emptyRecordP = mkRecordP Proxy HNil++-- Converting between RecordP and Record (label/value pairs)++-- The following class declares a bijection between Record and recordP+class HRLabelSet r => RecordR2P (r::[*]) (ls::[*]) (vs::[*]) | r -> ls vs, ls vs -> r where+    record_r2p :: Record r -> RecordP ls vs+    record_p2r :: RecordP ls vs -> Record r++instance RecordR2P ('[]) ('[]) ('[]) where+    record_r2p _ = emptyRecordP+    record_p2r _ = emptyRecord++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+-- to save the coding time (rather than run-time), we just+-- convert RecordP to regular Record, which we know how to show++instance (RecordR2P r ls vs, ShowComponents r, HRLabelSet r) =>+    Show (RecordP ls vs) where show rp = show $ record_p2r rp+++-- --------------------------------------------------------------------------+-- Extension for records++instance (HLabelSet (l ': ls), SameLength ls vs)+    => HExtend (Tagged l v) (RecordP ls vs)+ where+  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''+         , 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')+ where+  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++-- Because hLookupByLabel is so frequent and important, we+-- 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 (l' ': ls) vs v)+    => HasField l (RecordP (l' ': ls) vs) v where+    hLookupByLabel = hLookupByLabelP' (Proxy :: Proxy b)++class HasFieldP' b l ls vs v | b l ls vs -> v where+    hLookupByLabelP' :: Proxy b -> Label l -> RecordP ls vs -> v++instance HasFieldP' True l (l ': ls) (v ': vs) v where+    hLookupByLabelP' _ _ (RecordP (HCons v _)) = v++instance HasField l (RecordP ls vs) v+    => 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 =>+                   l -> RecordP ls vs -> RecordP lso vso+hDeleteAtLabelP l r = snd $ h2ProjectByLabelP l r+++-- --------------------------------------------------------------------------+-- Update operation+hUpdateAtLabelP :: (HUpdateAtHNat n e1 t1 l', HFind e t n) => +		   e -> e1 -> RecordP t t1 -> RecordP ls l'+hUpdateAtLabelP l v rp@(RecordP vs) = RecordP (hUpdateAtHNat n v vs)+ where+  n       = hFind l (labels_of_recordp rp)+-}++-- --------------------------------------------------------------------------+-- Projection for records+-- It is also an important operation: the basis of many+-- deconstructors -- so we try to implement it efficiently.++-- Project by a single label+class HProjectByLabelP l ls vs lso v vso | l ls vs -> lso v vso where+    h2ProjectByLabelP :: Label l -> RecordP ls vs -> (v,RecordP lso vso)++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' :: Proxy b -> Label l -> RecordP ls vs -> (v,RecordP lso vso)++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' 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))+++-- Invariant: r = rin `disjoint-union` rout+--            labels(rin) = ls+-- classes H2ProjectByLabels and H2ProjectByLabels' are declared in+-- Record.hs++{- 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 (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' 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' 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++-- Hmm, a bit too conservative. It works for all our examples,+-- where the record extension is by simple extension. In the future,+-- we should account for possible field permutation.++instance H2ProjectByLabels ls' (RecordP ls vs) (RecordP ls' vs') rout+    =>  SubType (RecordP ls vs) (RecordP ls' vs')+    -}
+ Data/HList/broken/VariantP.hs view
@@ -0,0 +1,190 @@+{- |+Modeling of an extensible, recursive sum datatype (recursive open union)++>  data List a = Nil | Cons a (List a)++which is later extended with two more variants,++>  ... | Unit a | App (List a) (List a)++Our goals:++  * any function that accepts the extended data list+    must also accept the unextended list.++  * it should be possible to `extend' the function that operates+    on plain lists to operate on extended list. We should be able+    to reuse as much of the old code as possible.++It seems, we have achieved our goals.++/Method/: duality rules! Curry-Howard correspondence and logic+give the wonderful guidance. In particular, we take advantage+of the fact that the deMorgan law++>     NOT (A | B) -> (NOT A & NOT B)++holds both in classical, and, more importantly, intuitionistic+logics. Our encoding of sums is the straightforward Curry-Howard+image of the law.++Note, the code below has no type classes, no type-level programming+or any other type hacking. In fact, there are no type annotations,+type declarations, or any other mentioning of types, except in the comments+-}++module Data.HList.VariantP where++import Data.HList.CommonMain+import Data.HList.Label1+++-- Declare labels for extensible records -- or, dually, for+-- extensible variants+-- We used the simplest field labels. They are a bit+-- ungainly to use -- but let us avoid overlapping instance extension.+-- See OOHaskell for the use of more advanced labels.++l_nil   = firstLabel+l_cons  = nextLabel l_nil++nil consumer = consumer .!. l_nil++cons a l consumer = (consumer .!. l_cons) a (l consumer)++tl1 c = cons 'a' (cons 'b' (cons 'c' nil)) c+tl2 c = cons 10 (cons 1 (cons 2 (cons 3 nil))) c++{-+  The inferred type of tl1 is++*Variants> :t tl1+tl1 :: (HasField (Label (HSucc HZero)) r (Char -> v -> v),+        HasField (Label HZero) r v) =>+       r -> v++which basically says that tl1 accepts any consumer that has at least+fields l_nil and l_cons with appropriate types. The consumer+may have more fields+-}+++-- First polymorphic function: provide a regular list "view" of our list++to_list () =     l_nil  .=. []+             .*. l_cons .=. (:)+             .*. emptyRecord++-- I wish GHC supported unicode in identifiers+tekiyou consumer lst = lst (consumer ())++test1 = tekiyou to_list tl1+-- "abc"+test2 = tekiyou to_list tl2+-- [10,1,2,3]+++-- another function, length++lengthL () =  l_nil  .=. 0+          .*. l_cons .=. (\x a -> a + 1)+          .*. emptyRecord++test_lL1 = tekiyou lengthL tl1+-- 3+test_lL2 = tekiyou lengthL tl2+-- 4+++-- Now, add extension to our record -- and, dually, extend our variant++l_unit = nextLabel l_cons+l_app  = nextLabel l_unit++unit a c = (c .!. l_unit) a++app l1 l2 c = (c .!. l_app) (l1 c) (l2 c)++tl3 c = cons 1 (unit 2) c+tl4 c = cons 10 (app tl3 tl2) c++sumA () =  l_nil  .=. 0+       .*. l_cons .=. (+)+       .*. l_unit .=. id+       .*. l_app  .=. (+)+       .*. emptyRecord++-- we can apply sum to an original (unextended) list+test_sum1 = tekiyou sumA tl2+-- 16++-- now, we can apply sum to an extended list+test_sum2 = tekiyou sumA tl4+-- 29++-- we can't pass extended lists tl3 and tl4 to a regular lenghtL+-- The error message says that the field l_unit is missing+-- test_lL3 = tekiyou lengthL tl3+++-- now we can attempt to extend lengthL, reusing as much of previous+-- functionality as possible++lengthA () =  l_unit .=. const 1+          .*. l_app  .=. (+)+          .*. (lengthL ())++test_lL4 = tekiyou lengthA tl3+-- 2+test_lL5 = tekiyou lengthA tl4+-- 7+++-- A few methods to show that our extensible lists indeed act+-- as regular lists (that is, support the regular list API).++-- check if the (extensible list) is null:+el_null l = l (l_nil .=. True .*. l_cons .=. (\_ _ -> False)+               .*. emptyRecord)++el_head l = l (l_nil .=. undefined .*. l_cons .=. (\x _ -> x)+               .*. emptyRecord)++el_tail l = l (    l_nil .=. (\f -> if f then undefined else nil)+               .*. l_cons .=. (\x a f -> if f then a False else+                               cons x (a False))+               .*. emptyRecord) True++test_ell = (el_null tl1, el_head tl1, tekiyou to_list $ el_tail tl1)+++-- convert from the regular list+from_list l = foldr cons nil l++test_ft1 = tekiyou to_list $ from_list "abcd"+-- "abcd"+++-- Binary methods.+-- Hmm, doing it directly is complicated. OTH, we can use the list view+-- (to_list) and solve the problem this way...+-- Laziness helps...++eqL l1 l2 = tekiyou to_list l1 == tekiyou to_list l2+test_eq1 = eqL tl1 tl1             -- True+test_eq2 = eqL tl1 (cons 'a' nil)  -- False+test_eq3 = eqL tl1 nil             -- False++-- we can extend to_list as usual++to_listA () =  l_unit .=. (:[])+           .*. l_app  .=. (++)+           .*. (to_list ())++-- And we can arbitrary mix old and extended lists+eqA l1 l2 = tekiyou to_listA l1 == tekiyou to_listA l2+test_eq4, test_eq5, test_eq6 :: Bool+test_eq4 = eqA tl1 tl1   -- True+test_eq5 = eqA tl2 tl3   -- False+test_eq6 = eqA tl3 tl4   -- False+
+ Data/HList/obsolete/Curry.hs view
@@ -0,0 +1,33 @@+module Curry where++import MainGhcGeneric1++class HUncurry f d c | f -> d c+ where+  hUncurry :: f -> d -> c++instance (FunType y b, HUncurry' b x y d c) => HUncurry (x -> y) d c+ where+  hUncurry (f::x->y) = hUncurry' (funType (undefined::y)) f++class HUncurry' b x y d c | b x y -> d c+ where+  hUncurry' :: b -> (x -> y) -> d -> c++instance HUncurry' HFalse x y (x,()) y+ where+  hUncurry' _ f (x,()) = f x++instance HUncurry y d c => HUncurry' HTrue x y (x,d) c+ where+  hUncurry' _ (f::x->y) (x,d) = hUncurry (f x) d++fun1 :: Int -> Int -> Int+fun1 = (+)++fun2 = hUncurry fun1++main = do+          print $ fun1 1 2+          print $ fun2 (1,(2,()))+
+ Data/HList/obsolete/GhcExperiments.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, KindSignatures, MultiParamTypeClasses, OverlappingInstances, UndecidableInstances #-}++{-+   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   This module gathers experiments that do not work with Hugs.+-}++module Data.HList.GhcExperiments where++import Data.HList.FakePrelude+import Data.HList.HListPrelude++class HDeleteMany e l l' | e l -> l'+ where+  hDeleteMany :: Proxy e -> l -> l'++instance HDeleteMany e HNil HNil+ where+  hDeleteMany _ HNil = HNil++instance (HList l, HDeleteMany e l l')+      => HDeleteMany e (HCons e l) l'+ where+  hDeleteMany p (HCons _ l) = hDeleteMany p l++{-++-- Hopelessly overlapping++instance (HList l, HDeleteMany e l l')+      => HDeleteMany e (HCons e' l) (HCons e' l')+ where+  hDeleteMany p (HCons e' l)+   =+     HCons e' (hDeleteMany p l)++-}++instance ( HList l+         , HDeleteMany e l l'+         , TypeCast (HCons e' l') l''+         )+      =>   HDeleteMany e (HCons e' l) l''+ where+  hDeleteMany p (HCons e' l)+   =+     typeCast (HCons e' (hDeleteMany p l))+++-----------------------------------------------------------------------------++-- Test for type constructors++-- signature: * -> *+class IsTC1 x (f :: * -> *) b | x f -> b+instance TypeCast HTrue b => IsTC1 (f a) f b+instance TypeCast HFalse b => IsTC1 f x b++-- signature: * -> * -> *+class IsTC2 x (f :: * -> * -> *) b | x f -> b+instance TypeCast HTrue b => IsTC2 (f a b) f b+instance TypeCast HFalse b => IsTC2 f x b++-- Sample+funType :: IsTC2 t ((->))b=> t -> b+funType = undefined
+ Data/HList/obsolete/GhcSyntax.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Some dedicated infix operators at the type and the value level.+-}++module Data.HList.GhcSyntax where++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import Data.HList.Record+import Data.HList.GhcRecord+import Data.HList.HArray+++{-----------------------------------------------------------------------------}++-- * For types++infixr 2 :*:+infixr 2 .*.++type e :*: l = HCons e l+++infixr 4 :=:+type l :=: v = LVPair l v++infixr 4 .=.+++{-----------------------------------------------------------------------------}++-- * For records++{-|++  [@(.*.)@]+           Add a field to a record. Analagous to (++) for+           lists.++  > record .*. field1+  >        .*. field2++-}+(.*.) :: HExtend e l l' => e -> l -> l'+(.*.) =  hExtend++{-|++  Create a value with the given label. Analagous to a data+  constructor such as 'Just', 'Left', or 'Right'. Higher fixity+  than record-modification operations like (.*.), (.-.), etc. to+  support expression like the below w/o parentheses:++  > label1 .=. value1 .*.+  > label2 .=. value2 .*.+  > emptyRecord++-}+(.=.) :: l -> v -> LVPair l v+l .=. v = newLVPair l v++infixr 9 .!.+{-|+  Lookup a value in a record, by its label. Analagous to (!!), the+  list indexing operation. Highest fixity, like (!!).++  > record1 .*. label1 .=. record2 .!. label1+  >         .*. label2 .=. record2 .!. label2++-}+(.!.) :: (HasField l r v) => r -> l -> v+r .!. l =  hLookupByLabel l r++infixl 2 .-.+{-|+  Remove a field from a record. At the same+  level as other record modification options (.*.). Analagous+  to (\\) in lists.++  > record1 .-. label1++  > label1 .=. value1 .*.+  > label2 .=. value2 .-.+  > label2 .*.+  > emptyRecord++  > label1 .=. value1 .-.+  > label1 .*.+  > label2 .=. value2 .*.+  > emptyRecord++  > record1 .*. label1 .=. record2 .!. label1+  >         .*. label2 .=. record2 .!. label2+  >         .-. label1++-}+(.-.) :: (H2ProjectByLabels (HCons e HNil) r _r' r') =>+    Record r -> e -> Record r'+r .-. l =  hDeleteAtLabel l r++infixr 2 .@.+{-|++  Update a field with a particular value.+  Same fixity as (.*.) so that extensions and updates can be chained.+  There is no real list analogue, since there is no Prelude defined+  update.++  > label1 .=. value1 .@. record1++-}+(.@.) :: (HUpdateAtHNat n (LVPair t t1) t2 l',HFind t ls n,RecordLabels t2 ls) =>LVPair t t1 -> Record t2 -> Record l'+f@(LVPair v) .@. r  =  hUpdateAtLabel (labelLVPair f) v r++infixr 2 .^.+{-|+  This is a variation on updating (according to GhcRecord.hs),+  so use the same fixity as (.\@.).+-}+(.^.) :: (HUpdateAtHNat n (LVPair t t1) t2 l',HFind t ls n,RecordLabels t2 ls,HasField t t2 (Proxy t1)) =>LVPair t t1 -> Record t2 -> Record l'+f@(LVPair v) .^. r = hUnproxyLabel (labelLVPair f) v r++infixr 2 .<.+{-|+  Another variation on update, so give it the same fixity as (.\@.).++-}+(.<.) :: (HasField t t2 t1,HUpdateAtHNat n (LVPair t t1) t2 l',HFind t ls n,RecordLabels t2 ls) =>LVPair t t1 -> Record t2 -> Record l'+f@(LVPair v) .<. r = hTPupdateAtLabel (labelLVPair f) v r++infixl 1 .<++.+{-|+  Similar to list append, so give this slightly lower fixity than+  (.*.), so we can write:++   > field1 .=. value .*. record1 .<++. record2++-}+(.<++.) ::  (HLeftUnion r r' r'') => r -> r' -> r''+r .<++. r' = hLeftUnion r r'+++{-----------------------------------------------------------------------------}++-- Convenience notation for TIRs++infixr 2 :+:+infixr 2 .+.++type e :+: l = HCons (Proxy e) l++{-|+  Type-indexed rows append. Very similar to (.*.), so+  keep the same fixity.+-}+(.+.) ::  (HExtend (Proxy e) l l') => e -> l -> l'+e .+. r = hExtend (toProxy e) r+++{-----------------------------------------------------------------------------}
+ Data/HList/obsolete/TypeCastGeneric1.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A generic implementation of type cast. For this implementation to+   work, we need to import it at a higher level in the module hierarchy+   than all clients of the class. Otherwise, type simplification will+   inline TypeCast x y, which implies compile-time unification of x and y.++   This technique works fine for ghc, and within limits for hugs.+-}++module Data.HList.TypeCastGeneric1 where++import Data.HList.FakePrelude++instance TypeCast x x+ where+  typeCast = id
+ Data/HList/obsolete/TypeCastGeneric2.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A generic implementation of a type-safe cast. The specific coding+   here is only shown for completeness' sake and it is explained in the+   TR version of the paper. The shown coding does not rely on separate+   compilation (while "Data.HList.TypeCastGeneric1" does), but on some other+   tricks.+-}++module Data.HList.TypeCastGeneric2 where++-- We make everything self-contained to show that separate compilation+-- is not needed.++import Data.HList.FakePrelude () -- hiding (TypeCast,typeCast)+++{-----------------------------------------------------------------------------}++-- The actual encoding++class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b+class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b+class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b+instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x+instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''+instance TypeCast'' () a a where typeCast'' _ x  = x+++{-----------------------------------------------------------------------------}
+ Data/HList/obsolete/TypeCastGeneric3.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A generic implementation of a type-safe cast. The specific coding+   here is only shown for completeness' sake and it is explained in the+   TR version of the paper. The shown coding does not rely on separate+   compilation (while "Data.HList.TypeCastGeneric1" does), but on some other+   tricks.+-}++module Data.HList.TypeCastGeneric3 where++import Data.HList.FakePrelude+++{-----------------------------------------------------------------------------}++-- The actual encoding++-- The class TypeCast is declared in FakePrelude.+-- class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b+class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b+class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b+instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x+instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''+instance TypeCast'' () a a where typeCast'' _ x  = x+++{-----------------------------------------------------------------------------}
+ Data/HList/obsolete/TypeEqBoolGeneric.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Generic implementations of type equality and disequality+-}++module Data.HList.TypeEqBoolGeneric where++import Data.HList.FakePrelude++instance            TypeEqTrue  x x+instance Fail () => TypeEqFalse x x+instance            TypeEqFalse x y
+ Data/HList/obsolete/TypeEqGeneric1.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,+  FlexibleContexts, OverlappingInstances, UndecidableInstances #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A generic implementation of a type equality predicate. The given+   implementation only works for GHC. It relies on two properties+   of GHC instance selection: (i) selection is lazy, and the negation+   of the constraints of the more specific instance is assumed for+   the more general instance.++   The specific encoding given here makes use of TypeCast,+   and by transitive closure therefore relies on separate compilation+   of TypeCast clients and the TypeCast instance.++   There is another encoding in "Data.Hlist.TypeEqGeneric2".+-}++module Data.HList.TypeEqGeneric1 where++import Data.HList.FakePrelude++instance TypeEq x x HTrue+instance (HBool b, TypeCast HFalse b) => TypeEq x y b+-- instance TypeEq x y HFalse -- would violate functional dependency+++class HBool b => TupleType t b | t -> b+instance TupleType () HTrue+instance TupleType (x,y) HTrue+instance TupleType (x,y,z) HTrue+-- Continue for a while+instance (HBool b, TypeCast HFalse b) => TupleType x b+-- instance TupleType x HFalse -- would violate functional dependency
+ Data/HList/obsolete/TypeEqGeneric2.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, UndecidableInstances, OverlappingInstances #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A generic implementation of a type equality predicate. The given+   implementation only works for GHC. The specific coding here is only+   shown for completeness' sake. We actually favour the encoding from+   "Data.Hlist.TypeEqGeneric1" for its conciseness. The specific coding here+   does not rely on separate compilation (while TypeEqGeneric1.hs+   does), but on some other tricks.+-}++module Data.HList.TypeEqGeneric2 where++-- We make everything self-contained to show that separate compilation+-- is not needed. Also, we need a new class constraint for TypeEqBool,+-- (unless we again employ separate compilation in some ways) so+-- that instance selection of its generic instance within client code+-- of TypeEqBool does not issue problems with the instance+-- constraints.++import Data.HList.FakePrelude hiding (TypeEq,typeEq,proxyEq,TypeCast,typeCast)+import Data.HList.TypeCastGeneric2++-- Re-enabled for testing++typeEq :: TypeEq t t' b => t -> t' -> b+typeEq = undefined+++{-----------------------------------------------------------------------------}++-- The actual encoding++class TypeEq' () x y b => TypeEq x y b | x y -> b+class TypeEq' q x y b | q x y -> b+class TypeEq'' q x y b | q x y -> b+instance TypeEq' () x y b => TypeEq x y b+-- This instance used to work <= GHC 6.2+-- instance TypeEq' () x x HTrue+-- There were some problems however with GHC CVS 6.3.+-- So we favour the following, more stable (?) instance instead.+instance TypeCast b HTrue => TypeEq' () x x b+instance TypeEq'' q x y b => TypeEq' q x y b+instance TypeEq'' () x y HFalse++{-----------------------------------------------------------------------------}
+ Data/HList/obsolete/TypeEqGeneric3.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, FlexibleInstances, UndecidableInstances, OverlappingInstances #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   A generic implementation of a type equality predicate. The given+   implementation only works for GHC. The specific coding here is only+   shown for completeness' sake. We actually favour the encoding from+   "Data.HList.TypeEqGeneric1" for its conciseness. The specific coding here+   does not rely on separate compilation (while TypeEqGeneric1.hs+   does), but on some other tricks.+-}++module Data.HList.TypeEqGeneric3 where++-- We make everything self-contained to show that separate compilation+-- is not needed. Also, we need a new class constraint for TypeEqBool,+-- (unless we again employ separate compilation in some ways) so+-- that instance selection of its generic instance within client code+-- of TypeEqBool does not issue problems with the instance+-- constraints.++import Data.HList.FakePrelude+import Data.HList.TypeCastGeneric3++-- Re-enabled for testing++typeEq :: TypeEq t t' b => t -> t' -> b+typeEq = undefined+++{-----------------------------------------------------------------------------}++-- The actual encoding++-- TypeEq class itself is declared in FakePrelude+-- class TypeEq' () x y b => TypeEq x y b | x y -> b+class TypeEq' q x y b | q x y -> b+class TypeEq'' q x y b | q x y -> b+instance (HBool b, TypeEq' () x y b) => TypeEq x y b+instance TypeCast b HTrue => TypeEq' () x x b+instance TypeEq'' q x y b => TypeEq' q x y b+instance TypeEq'' () x y HFalse++{-----------------------------------------------------------------------------}
HList.cabal view
@@ -1,31 +1,220 @@ Name:                HList-Version:             0.2.3+Version:             0.5.4.0 Category:            Data Synopsis:            Heterogeneous lists-Description:         HList is a record system providing strongly typed heterogenous lists, records,-                     type-indexed products (TIP) and co-products; licensed under the MIT X License.+Description:         HList provides many operations to create and manipulate+                     heterogenous lists (HLists) whose length and element+                     types are known at compile-time. HLists are used to implement+                    .+                      * records+                    .+                      * variants+                    .+                      * type-indexed products (TIP)+                    .+                      * type-indexed co-products (TIC)+                    .+                      * keyword arguments+                    .+                     User code should import "Data.HList" or+                     "Data.HList.CommonMain" for a slightly more limited scope+                    .+                     The original design is described in <http://okmij.org/ftp/Haskell/HList-ext.pdf>,+                     though since that paper came out, the -XTypeFamiles extension has been used to+                     replace `TypeCast` with `~`. License:             MIT License-File:        LICENSE Author:              2004 Oleg Kiselyov (FNMOC, Monterey), Ralf Laemmel (CWI/VU, Amsterdam),-                     Keean Schupke (Imperial College, London)+                     Keean Schupke (London) Maintainer:          oleg@pobox.com -Data-files:          README-Cabal-version:       >= 1.4-Tested-With:         GHC==6.12.1-Build-Depends:       base >= 3 && < 5, template-haskell+Data-files:          README, ChangeLog+Cabal-version:       >= 1.10+Tested-With:         GHC==9.4.8, GHC==9.6.6, GHC==9.8.2, GHC==9.10.1 Build-Type:          Simple-Exposed-modules:     Data.HList, Data.HList.CommonMain, Data.HList.Variant, Data.HList.GhcSyntax,-                     Data.HList.GhcRecord, Data.HList.Record, Data.HList.HZip, Data.HList.TIC, Data.HList.TIP,-                     Data.HList.HTypeIndexed, Data.HList.HOccurs, Data.HList.HArray, Data.HList.GhcExperiments,-                     Data.HList.HListPrelude, Data.HList.TypeEqBoolGeneric, Data.HList.TypeEqGeneric1,-                     Data.HList.TypeCastGeneric1, Data.HList.TypeCastGeneric2, Data.HList.FakePrelude, -                     Data.HList.RecordP, Data.HList.TypeEqGeneric2,-                     Data.HList.Label1, Data.HList.Label2, Data.HList.Label3, Data.HList.Label4, Data.HList.Label5, -                     Data.HList.MakeLabels+Extra-Source-Files:+                     examples/broken/*.hs,+                     examples/broken/*.lhs,+                     examples/broken/*.ref, -extensions:          EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,-                     MultiParamTypeClasses, OverlappingInstances, ScopedTypeVariables, RankNTypes,-                     ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances-ghc-options:         -Wall+                     Data/HList/broken/*.hs,+                     Data/HList/obsolete/*.hs++Source-Repository head+    type: git+    location: https://bitbucket.org/HList/hlist+++flag new_type_eq+  Default: False+  Manual: True+  Description: use Data.Type.Equality.== to define the instance of HEq+               instead of overlapping instances (in Data.HList.TypeEqO)+               (needs ghc >= 7.8)+              .+               This version does not allow `HEq x [x] f` to lead to+               f ~ False, unlike the version with overlapping instances.+               See <https://ghc.haskell.org/trac/ghc/ticket/9918>++library+  Build-Depends:       base >= 4.6 && < 4.21,+                       -- for Typeable '[] and '(:) with ghc-7.6+                       base-orphans,+                       -- Data.Semigroup for ghc < 8+                       semigroups,+                       template-haskell,+                       ghc-prim,+                       mtl,+                       tagged,+                       profunctors,+                       array+++  Exposed-modules:     Data.HList,+                       Data.HList.CommonMain,+                       Data.HList.Data,+                       Data.HList.Dredge,+                       Data.HList.FakePrelude,+                       Data.HList.HArray,+                       Data.HList.HCurry,+                       Data.HList.HList,+                       Data.HList.HListPrelude,+                       Data.HList.HOccurs,+                       Data.HList.HTypeIndexed,+                       Data.HList.HSort,+                       Data.HList.HZip,+                       Data.HList.Keyword,+                       Data.HList.Label3,+                       Data.HList.Label5,+                       Data.HList.Label6,+                       Data.HList.Labelable,+                       Data.HList.MakeLabels,+                       Data.HList.Record,+                       Data.HList.RecordPuns,+                       Data.HList.RecordU,+                       Data.HList.TIC,+                       Data.HList.TIP,+                       Data.HList.TIPtuple,+                       Data.HList.TypeEqO,+                       Data.HList.Variant+  Other-modules:       LensDefs+  Default-Language:    Haskell2010+++  Ghc-Options:         -Wall -fno-warn-missing-signatures -fno-warn-orphans++  Default-Extensions:  ConstraintKinds+                       DataKinds+                       DeriveDataTypeable+                       EmptyDataDecls+                       FlexibleContexts+                       FlexibleInstances+                       FunctionalDependencies+                       GeneralizedNewtypeDeriving+                       GADTs+                       KindSignatures+                       MultiParamTypeClasses+                       PolyKinds+                       RankNTypes+                       ScopedTypeVariables+                       StandaloneDeriving+                       TypeFamilies+                       TypeOperators+                       UndecidableInstances+  Other-Extensions:    CPP+                       TemplateHaskell+                       OverlappingInstances+  if impl(ghc >= 8.6)+    Default-Extensions: StarIsType++  if impl(ghc >= 8.0)+    Default-Extensions: UndecidableSuperClasses++  if impl(ghc < 7.7)+    Cpp-options:       -DOLD_TYPEABLE -DNO_CLOSED_TF++  if impl(ghc >= 7.7)+    Default-Extensions: AllowAmbiguousTypes+                        RoleAnnotations++  if impl(ghc > 7.9)+    Ghc-Options:      -fno-warn-unticked-promoted-constructors+                      -Wno-star-is-type++  if flag(new_type_eq)+    Cpp-options:       -DNEW_TYPE_EQ+    Build-Depends:     base >= 4.7 && < 4.21++Test-Suite examples+  Type:     exitcode-stdio-1.0+  Main-Is: HListExample.hs+  Default-Language:    Haskell2010+  Hs-Source-Dirs:  examples+  Build-Depends:       base < 4.21, hspec >= 1.7, directory, filepath,+                       hspec-expectations,+                       process,+                       syb,+                       cmdargs,+                       lens,+                       HList,+                       mtl,+                       QuickCheck,+                       array,+                       semigroups,+                       template-haskell+  Other-Modules:+        Properties.Common++        HListExample.CmdArgs+        HListExample.Datatypes2+        HListExample.Labelable+        HListExample.MainGhcGeneric1+        HListExample.MainPosting051106+        HListExample.OverloadedLabels+        HListExample.Prism+        HListExample.Pun+        HListExample.TIPTransform+        HListExample.TIPTransformM++  if impl(ghc > 7.9)+    Ghc-Options: -fno-warn-tabs++Test-Suite doctests+  Type:     exitcode-stdio-1.0+  Ghc-Options: -threaded+  if impl(ghc <= 7.9 ) && impl(ghc <= 7.11)+    -- doctests include things like :t pred . maxBound, which+    -- depending on the ghc version, comes out as one of+    -- (Bounded a, Enum a) => ...+    -- (Enum b, Bounded b) => ...+    Build-Depends: base < 4.21, doctest >= 0.8, process+  Buildable: False+  Main-Is: rundoctests.hs+  Hs-Source-Dirs:  examples+  Default-Language:    Haskell2010+++Test-Suite properties+  Type:     exitcode-stdio-1.0+  Build-Depends: base < 4.21,+                 hspec >= 1.7,+                 hspec-expectations,+                 HList,+                 lens,+                 mtl,+                 QuickCheck,+                 template-haskell,+                 array,+                 syb+  Other-Modules:+        Properties.Common+        Properties.KW+        Properties.LengthDependent+        Properties.LengthDependentSplice+        Properties.LengthIndependent+  Main-Is:  Properties.hs+  Hs-Source-Dirs: examples+  Default-Language:    Haskell2010+  if impl(ghc <= 7.11)+        build-depends: semigroups
+ LensDefs.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+-- | parts of lens that would be imported if we depended on it+module LensDefs+  (module LensDefs,+   module Control.Applicative,+   Choice,+   Profunctor,+   Coercible)+   where++import Data.Profunctor+import Data.Profunctor.Unsafe+import Control.Applicative+import Control.Monad.Identity++import Unsafe.Coerce+#if __GLASGOW_HASKELL__ > 707+import GHC.Exts(Coercible)+#else+import GHC.Exts(Constraint)+-- | for ghc-7.6 we don't have coercible+type Coercible a b = (() :: Constraint)+#endif+++type Equality' s a = forall p (f :: * -> *). a `p` f a -> s `p` f s++{- | if we write @f' = simple . f@, then the inferred type is++> f' :: (s ~ t, _) => Lens s t a b++which normally will let ghc figure out (a~b). However with the+types that come up in HList this can only be figure out with+concrete types, so we use isSimple instead which also specifies+(a~b).++-}+isSimple :: optic ~ (p a (f a) -> p s (f s)) => optic -> optic+isSimple = id+-- alternatively: isSimple x = simple . x . simple++simple :: Equality' a a+simple = id++-- Used by doctests (which should probably just import Control.Lens...)+infixl 1 &+x & f = f x++infixr 4 %~+l %~ f = \t -> runIdentity $ l (rmap Identity f) t++iso :: (Profunctor p, Functor f)+    => (s -> a) -> (b -> t)+    -> p a (f b) -> p s (f t)+iso sa bt = dimap sa (fmap bt)++-- | iso, except assumes that the functions supplied could+-- be 'Data.Coerce.coerce'+isoNewtype :: (Profunctor p, Functor f,+               Coercible b t, -- Coercible (f b) (f t) -- is really needed but that complicates types later on (since f is forall'd)+               Coercible a s)+    => (s -> a) -> (b -> t)+    -> p a (f b) -> p s (f t)+isoNewtype sa _bt x = coerceBT x .# sa+  where coerceBT :: p a (f b) -> p a (f t)+        coerceBT = unsafeCoerce++prism :: (b -> t) -> (s -> Either t a)+    -> (forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t))+prism bt seta = dimap seta (either pure (fmap bt)) . right'++prism' :: (a -> s) -> (s -> Maybe a)+    -> (forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s))+prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))
README view
@@ -2,7 +2,7 @@  Contributors: 	Justin Bailey, Brian Bloniarz, Gwern Branwen, Einar Karttunen,-	and Adam Vogt+	Daniil Iaitskov and Adam Vogt   The HList library and samples@@ -11,37 +11,60 @@  Getting the code -> darcs get http://code.haskell.org/HList+> git clone https://bitbucket.org/HList/hlist HList  ----------------------------------------------------------------------  Pushing changes -You need an account at code.haskell.org+You need an account at bitbucket.org  > cd HList-> darcs pull user@code.haskell.org:/srv/darcs/HList-> darcs record-> darcs push+> git clone git@bitbucket.org:HList/hlist.git+> git pull+> git commit --interactive+> git push  ---------------------------------------------------------------------- -This distribution covers all essential issues discussed in the HList paper.+This distribution covers all essential issues discussed in the HList paper,+though the implementation has been adapted to ghc features implemented+after the paper's writing.+ Additional examples and HList operations are provided. The code from the database section of the HList paper is not included since doing so would have implied inclusion of substantial packages, namely the underlying infrastructure for database access library. -You can get HList from Hackage or from Darcs:+You can get HList from Hackage or from bitbucket: -$ darcs get --partial http://code.haskell.org/HList/+$ cabal update && cabal install HList -The code works --- within the limits exercised in the source files ----for both GHC (6.4) and Hugs (Nov 2003). See the -examples/Makefile for ways of running test cases.-The last GHC version tried: GHC 6.12+Or: -One may run "cd examples; make test" to check the distribution.+$ git clone https://bitbucket.org/HList/hlist HList+$ cd HList; cabal install -See ChangeLog for updates.+The code was tested --- within the limits exercised in the source files ---+with GHC 9.4.8 through 9.10.1 and it may still work older versions possibly back to+GHC-7.6 +Older compilers are not supported.++One may run "cabal test" to check the distribution.++----------------------------------------------------------------------++The library can be built and tested in the checked environment (with+compatible GHC, cabal and dependencies) provided by nix:++$ nix-build        # builds and runs tests+$ nix-shell --pure # drops into an isolated shell++nix usually can be installed with a single line:++$ sh <(curl -L https://nixos.org/nix/install) --no-daemon++----------------------------------------------------------------------++See ChangeLog for updates.
− Setup.hs 
@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-import Distribution.Simple-main = defaultMainWithHooks defaultUserHooks
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ examples/HListExample.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- tests based on HListExample+module Main (main) where+++import Test.Hspec+++import HListExample.Labelable+import HListExample.CmdArgs+import HListExample.MainGhcGeneric1+-- import HListExample.MainPosting040607+import HListExample.MainPosting051106+import HListExample.Prism+import HListExample.Pun+import HListExample.TIPTransform+import HListExample.TIPTransformM+import HListExample.OverloadedLabels+++main = hspec $ do+  mainCmdargs+  mainLabelable+  mainGhcGeneric1+  mainPosting051106+  mainPrism+  mainPun+  mainTIPTransform+  mainTTIPM+  mainOverloadedLabels++++++
+ examples/HListExample/CmdArgs.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}+module HListExample.CmdArgs where+++import Data.Generics+import Control.Lens+import Test.Hspec+import Properties.Common++import Data.HList.CommonMain++import System.Console.CmdArgs (cmdArgs)+import System.Environment (withArgs)+++{-++An example showing off the data instance for Record / Variant / TIP / TIC++Also a use of cmdArgs++Note that ghc-7.8.2 does not have (or can produce) instances of typeable+for types of kind Symbol (ie. promoted strings):+<https://ghc.haskell.org/trac/ghc/ticket/9111>, so for now use the Label3+style++-}++#define USE_LABEL3 __GLASGOW_HASKELL__ == 708++#if USE_LABEL3+makeLabels3 "examples_cmdargs" (words "x y z tic")+makeLabels3 "optV" (words "optA optB optC")+#else+makeLabels6 (words "x y z tic")+makeLabels6 (words "optA optB optC")+#endif++makeLabelable "abc df"++#if USE_LABEL3+v = (optA .*. optB .*. optC .*. emptyProxy)+      `zipTagged` (Proxy :: Proxy '[Int,Char,Double])+#else+v = Proxy :: Proxy '[Tagged "optA" Int, Tagged "optB" Char, Tagged "optC" Double]+#endif++type Z' = TagR [Int, Char, Double]+-- type Z' = [Tagged Int Int, Tagged Char Char, Tagged Double Double]++d0 = x .=. (5 :: Int)+    .*. y .=. True+    .*. z .=. mkVariant optC (1 :: Double) v+    .*. tic .=. mkTIC' 'x' (Proxy :: Proxy Z')+    .*. emptyRecord++-- the equivalent ordinary record for reference+data E = E { a :: Int, b :: Bool }+    deriving (Show, Data, Typeable)++data Opt = OptA Int | OptB Char | OptC Double+    deriving (Show, Data, Typeable)++e0 = E 5 True++mainCmdargs = describe "cmdargs/Data" $ do+  it "variant show" $+    mkVariant optC 1 v `shouldShowTo` "V{optC=1.0}"++  -- increment V{optC=1.0} via data instance+  it "gmapT" $+    gmapT (mkT ((+1) :: Double -> Double)) (mkVariant optC 1 v)+     `shouldShowTo` "V{optC=2.0}"++  it "d0" $+    d0 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Bool children" $+    gmapT (mkT not) d0 `shouldShowTo`+      "Record{x=5,y=False,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Int children" $+    gmapT (mkT (+(1::Int))) d0 `shouldShowTo`+      "Record{x=6,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Char children (none)" $+    gmapT (mkT (succ :: Char -> Char)) d0 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}"++  it "modify d0's Char grandchildren" $+    everywhere (mkT (succ :: Char -> Char)) d0 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='y'}}"++#if __GLASGOW_HASKELL__ != 706+  --  ghc-7.6.3 fails with all uses of dredge:+  --     Kind incompatibility when matching types:+  --    Const (Data.Monoid.First Double) Double :: AnyK+  --    Const (Data.Monoid.First Double) Double :: *++  it "dredge optC" $+    d0 & dredge optC +~ 1 `shouldShowTo`+      "Record{x=5,y=True,z=V{optC=2.0},tic=TIC{char='x'}}"+#endif++  -- theB is like a TIP the unsafe lookup function applied+  let theB :: Typeable a => a+      theB = error "theB"+            `extB` (1::Int)+            `extB` True+            `extB` (2.5::Double)+            `extB` 'b'+            `extB` mkVariant optC theB v+            `extB` mkTIC' (theB :: Char) (Proxy :: Proxy Z')++  it "fromConstrB" $+    fromConstrB theB undefined `asTypeOf` d0 `shouldShowTo`+      "Record{x=1,y=True,z=V{optC=2.5},tic=TIC{char='b'}}"++  it "cmdargs built-in data" $+    withArgs ["-a=4", "-b=False" ] (cmdArgs e0) `shouldReturnShowTo`+        "E {a = 4, b = False}"++  -- drop the tic and variant-containing fields: cmdargs doesn't support+  -- it. Cmdargs doesn't support fields containing+  -- `data Opt = OptA Int | OptB Char` either+  let dRec = d0 & from hListRecord %~ (hInit . hInit)++  it "dRec" $+    dRec `shouldShowTo`+      "Record{x=5,y=True}"++  it "cmdargs Record" $+    withArgs ["-x=4", "-y=False"] (cmdArgs dRec) `shouldReturnShowTo`+      "Record{x=4,y=False}"+
+ examples/HListExample/Datatypes2.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}++module HListExample.Datatypes2 where++import Data.Typeable++-- The fout-n-mouth example+-- (deriving Typeable only supported for GHC)++newtype Key     = Key Integer+                deriving (Show,Eq,Ord,Typeable)+newtype Name   = Name String+                deriving (Show,Eq,Typeable)+data Breed     = Cow | Sheep+                deriving (Show,Eq,Typeable)+newtype Price  = Price Float+                deriving (Show,Eq,Ord,Typeable)+data Disease   = BSE | FM+                deriving (Show,Eq,Typeable)
+ examples/HListExample/Labelable.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds,+  GADTs, ConstraintKinds #-}+{- | Demonstrates @hLens'@++may be worthwhile to have a lens-free test suite, doing stuff like:++> case x (Identity  . (++"there")) r of Identity t -> t++-}+module HListExample.Labelable where+import Data.HList.CommonMain+import Control.Lens++import Text.Read++import Properties.Common+import Test.Hspec+++makeLabelable "lbX lbY"++#if __GLASGOW_HASKELL__ < 707+#define INT_SIG_76 :: Int+#else+#define INT_SIG_76+#endif++r = lbX .==. "hi" .*.+    lbY .==. (lbY .==. 321 .*. lbX .==. 123 .*. emptyRecord) .*.+    emptyRecord++mainLabelable = describe "labelable" $ do+  it "lookup" $ do+    r ^. lbX      `shouldShowTo` "\"hi\""++    -- ghc-7.6 doesn't default when r is involved lower down,+    -- while 7.8.2 does+    (r ^. lbY . lbY  INT_SIG_76) `shouldShowTo` "321"+    (r ^. lbY . lbX  INT_SIG_76) `shouldShowTo` "123"++  it "modify" $ do+    r & lbX .~ () `shouldShowTo`+        "Record{lbX=(),lbY=Record{lbY=321,lbX=123}}"++    r & lbY . lbY .~ "xy" `shouldShowTo`+        "Record{lbX=\"hi\",lbY=Record{lbY=\"xy\",lbX=123}}"++  it "read/show" $ do+    let rString = "Record{lbX=\"hi\",lbY=Record{lbY=321,lbX=123}}"++    r `shouldShowTo` rString++    readMaybe rString `asTypeOf` Just r+        `shouldBe` Just r++    -- the read instance does not reorder labels+    let rStringPerm = "Record{lbY=Record{lbY=321,lbX=123},lbX=\"hi\"}"+    readMaybe rStringPerm `asTypeOf` Just r+        `shouldBe` Nothing++    -- but we can reorder this way+    (r ^. rearranged) `asTypeOf` (undefined :: Record '[Tagged "lbY" t, Tagged "lbX" s])+        `shouldShowTo` rStringPerm
+ examples/HListExample/MainGhcGeneric1.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++{-++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   This is a main module for exercising a model with generic type+   cast and generic type equality.++-}++module HListExample.MainGhcGeneric1 (mainGhcGeneric1) where++import HListExample.Datatypes2+import Data.HList.CommonMain+import Control.Lens++import Properties.Common+import Test.Hspec++import Control.Monad.Writer++-- --------------------------------------------------------------------------++type Animal =  '[Key,Name,Breed,Price]++angus :: HList Animal+angus =  HCons (Key 42)+           (HCons (Name "Angus")+           (HCons  Cow+           (HCons (Price 75.5)+            HNil)))++tlist1 = hFoldr (HSeq HPrint) (return () :: IO ()) angus++testBasic = do+  it "basic" $ do+    -- tlist1 does IO. The equivalent using Writer+    let f = HSeq $ HComp (tell . (:[])) HShow+        f2 = Fun (tell . (:[]) . show) :: Fun Show (Writer [String] ())++        angusStr = ["Key 42",  "Name \"Angus\"", "Cow", "Price 75.5" ]++    execWriter (hFoldr f (return ()) angus) `shouldBe`+        angusStr++    execWriter (hFoldr (HSeq f2) (return ()) angus) `shouldBe`+        angusStr+++    hAppend angus angus `shouldShowTo` +      "H[Key 42,Name \"Angus\",Cow,Price 75.5,Key 42,Name \"Angus\",Cow,Price 75.5]"+++testHArray = do+  it "HArray" $ do+    hProjectByHNats (hNats (HCons hZero (HCons hZero HNil))) angus `shouldShowTo`+      "H[Key 42]"++      -- Before:+      -- H[Key 42, Key 42]+      -- XXX I don't duplicate at present!+    hProjectByHNats (hNats (HCons hZero (HCons (hSucc hZero) HNil))) angus `shouldShowTo`+      "H[Key 42,Name \"Angus\"]"++    hProjectByHNats (undefined::Proxy ['HZero, 'HSucc 'HZero]) angus `shouldShowTo`+      "H[Key 42,Name \"Angus\"]"++    hProjectAwayByHNats (hNats (HCons hZero HNil)) angus `shouldShowTo`+      "H[Name \"Angus\",Cow,Price 75.5]"++    hSplitByHNats +	    (undefined::Proxy ['HZero, 'HSucc 'HZero])+	    angus+      `shouldShowTo`+      "(H[Key 42,Name \"Angus\"],H[Cow,Price 75.5])"+++  it "HOccurs" $ do+    (hOccurs angus :: Breed) `shouldShowTo` "Cow"+    hOccurs angus `shouldBe` Cow++    hOccurs (hBuild 1 ^. from tipHList) `shouldShowTo` "1"++    (null $ hOccurs $ hBuild [] ^. from tipHList) `shouldBe` True+    (hProject angus :: HList '[Key, Name]) `shouldShowTo`+      "H[Key 42,Name \"Angus\"]"+++  it "TypeIndexed" $ do+    let typeIdx1 = hDeleteMany (undefined::Proxy Name) angus+        typeIdx2 = BSE .*. angus+    typeIdx1 `shouldShowTo` "H[Key 42,Cow,Price 75.5]"+    typeIdx2 `shouldShowTo` "H[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]"++    hUpdateAt Sheep typeIdx1 `shouldShowTo`+      "H[Key 42,Sheep,Price 75.5]"+  +    hDeleteAt (undefined::Proxy Breed) typeIdx2 `shouldShowTo`+      "H[BSE,Key 42,Name \"Angus\",Price 75.5]"++    hProjectBy (undefined::Proxy '[Breed]) angus `shouldShowTo` "H[Cow]"++    hProject angus `shouldBe` HCons Cow HNil++    -- doesn't work+    -- hProjectBy Proxy angus `shouldBe` HCons Cow HNil++    hSplitBy (undefined:: Proxy '[Breed]) angus `shouldShowTo`+      "(H[Cow],H[Key 42,Name \"Angus\",Price 75.5])"++testTIP = do+  -- |+  -- This example from the TIR paper challenges singleton lists.+  -- Thanks to the HW 2004 reviewer who pointed out the value of this example.+  -- We note that the explicit type below is richer than the inferred type.+  -- This richer type was needed for making this operation more polymorphic.+  -- That is, /a)/ would not work without the explicit type, +  -- while /b/ would:+  --+  -- >  a)  ((+) (1::Int)) $ snd $ tuple oneTrue+  -- >  b)  ((+) (1::Int)) $ fst $ tuple oneTrue+  --+  -- As of 2014, type signatures are not needed to define tipyTuple.+  it "tipyTuple" $ do+    let tuple l = tipyTuple l++        -- oneTrue :: TIP (TagR [Int, Bool])		-- inferred+        -- oneTrue :: TIP '[Tagged Int Int, Tagged Bool Bool] -- expanded out+        oneTrue = (1::Int) .*. True .*. emptyTIP++    case tuple oneTrue of+      (a,b) -> (a+(1::Int), not b) `shouldShowTo` "(2,False)"++    not (fst (tuple oneTrue)) `shouldShowTo` "False"+    tuple oneTrue `shouldBe` (1::Int,True)++    (((+) (1::Int)) $ fst $ tuple oneTrue) `shouldBe` 2+    (((+) (1::Int)) $ snd $ tuple oneTrue) `shouldBe` 2+++  it "tip" $ do+    hOccurs myTipyCow `shouldBe` Cow+    (BSE .*. myTipyCow) `shouldShowTo` "TIPH[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]"+    -- (Sheep .*. myTipyCow) `shouldBe`  _+    {- if we uncomment the line above, we get the type error+       about the violation of the TIP condition: Breed type+       occurs twice.++      No instance for (Fail * (TypeFound Breed))+    -}++    (Sheep .*. hDeleteAtLabel (Label :: Label Breed) myTipyCow)+        `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]"++    (Sheep .*. (myTipyCow .-. (Label :: Label Breed)))+        `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]"++    tipyUpdate Sheep myTipyCow+        `shouldShowTo` "TIPH[Key 42,Name \"Angus\",Sheep,Price 75.5]"+++++myTipyCow = tipHList # angus -- lens #++animalKey :: ( SubType l (TIP Animal) -- explicit+             , HOccurs Key l          -- implicit+             ) => l -> Key+animalKey = hOccurs++animalish :: SubType l (TIP Animal) => l -> l+animalish = id+animalKey' l = hOccurs (animalish l) :: Key+++makeLabels3 "MyNS" (words "key name breed price")+{- ^ makeLabels3 generates something like+data MyNS = MyNS -- a name space for record labels++key   = firstLabel MyNS  (undefined::DKey)+name  = nextLabel  key   (undefined::DName)+breed = nextLabel  name  (undefined::DBreed)+price = nextLabel  breed (undefined::DPrice)++data DKey;   instance Show DKey   where show _ = "key"+data DName;  instance Show DName  where show _ = "name"+data DBreed; instance Show DBreed where show _ = "breed"+data DPrice; instance Show DPrice where show _ = "price"++-}++unpricedAngus =  key    .=. (42::Integer)+             .*. name   .=. "Angus"+             .*. breed  .=. Cow+             .*. emptyRecord+++testRecords = describe "testRecords" $ it "tests" $ do++  unpricedAngus `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Cow}"+  unpricedAngus .!. breed `shouldShowTo` "Cow"++  let test3 = hDeleteAtLabel breed unpricedAngus++  test3+    `shouldShowTo` "Record{key=42,name=\"Angus\"}"++  (breed .=. Sheep .@. unpricedAngus)+    `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Sheep}"++  let test4 = price .=. 8.8 .*. unpricedAngus++  test4+    `shouldShowTo` "Record{price=8.8,key=42,name=\"Angus\",breed=Cow}"++  hProjectByLabels (labelsOf (breed `HCons` price `HCons` HNil)) test4+    `shouldShowTo` "Record{price=8.8,breed=Cow}"++  -- XXX extra Label shouldn't be needed?+  -- alternatively it could be a compile-time error...+  -- hProjectByLabels (hEndP $ hBuild breed price) test4+  --  `shouldShowTo` "Record{price=8.8,breed=Cow}"++  -- test7 should be the same as test4 but+  -- with the different order of labels+  (newLVPair breed Sheep) .*. test3+    `shouldShowTo` "Record{breed=Sheep,key=42,name=\"Angus\"}"+++type AnimalCol = TagR [Key,Name,Breed,Price]+++testTIC = describe "TIC" $ do+  it "show" $+    (myCol :: TIC AnimalCol) `shouldShowTo` "TIC{breed=Cow}"+  it "hOccurs found" $+    (hOccurs myCol :: Maybe Breed) `shouldBe` Just Cow+  it "hOccurs absent" $+    (hOccurs myCol :: Maybe Price) `shouldBe` Nothing++myCol = mkTIC Cow :: TIC AnimalCol+{-++*TIC> mkTIC "42" :: TIC AnimalCol+Type error ...++*TIC> hOccurs myCol :: Maybe String+Type error ...++-- both of the these type errors could be better+-- (on ghc-7.10.3), Any is used to satisfy FD coverage condition, but the+-- TypeError context should be printed instead+<interactive>:170:1:+    Couldn't match type ‘Data.HList.CommonMain.Any’ with ‘[Char]’+    In the expression: mkTIC "42" :: TIC AnimalCol+    In an equation for ‘it’: it = mkTIC "42" :: TIC AnimalCol+-}++testVariant = describe "Variant" $ it "test" $ do+    testVar1 `shouldShowTo` "V{name=\"angus\"}"+    (testVar1 .!. key) `shouldBe` Nothing+    (testVar1 .!. name) `shouldBe` Just "angus"+ where+  testVar1 = mkVariant name "angus" animalVar++animalVar = asProxy $+               key   .=. (undefined :: Integer)+           .*. name  .=. (undefined :: String)+           .*. breed .=. (undefined :: Breed)+           .*. emptyRecord+++asProxy :: proxy a -> Proxy a+asProxy _ = Proxy++mainGhcGeneric1 = describe "mainGhcGeneric1" $ do+  testBasic+  testHArray+  testTIP+  testRecords+  testTIC+  testVariant
+ examples/HListExample/MainPosting051106.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# LANGUAGE TypeOperators #-}+#endif+module HListExample.MainPosting051106 where++-- Needed for a reply to the Haskell mailing list++import Data.HList.CommonMain hiding (Comp(..))+import Properties.Common+import Test.Hspec++mainPosting051106 = describe "hComposeList (a -> H[a -> b,b -> c,c -> d] -> d)" $ do+    it "defined here" $+        comp "abc" `shouldShowTo` "8"++    it "defined in HList" $+        hComposeList test2 "abc" `shouldShowTo` "8"++test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil))+test2 = length .*. (+1) .*. (*2) .*. HNil++data Comp++{- simpler class. wouldn't work with test2. The original HFoldr won't work with+ - Apply anymore.+instance Apply Comp (x -> y,y -> z)+ where+  type ApplyR Comp (x -> y,y -> z) = x -> z+  apply _ (f,g) = g . f+  -}++-- `~` is (built-in) TypeCast mentioned below+instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz)+    => ApplyAB Comp xyz xz+ where+  applyAB _ (f,g) = g . f++-- Function composition based on type code works.++comp  = hFoldr (undefined::Comp) (id::Int -> Int) test++-- Function composition based on normal polymorphism doesn't+-- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++{-++From Ralf.Lammel at microsoft.com  Mon Nov  7 00:11:01 2005+From: Ralf.Lammel at microsoft.com (Ralf Lammel)+Date: Sun Nov  6 23:50:27 2005+Subject: [Haskell-cafe] Type classes and hFoldr from HList+Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com>++Hi Greg,++Since hfoldr is right-associative, I prefer to reorder your list of+functions as follows:++> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons+((*2)::(Int->Int)) HNil))++Note that I also annotated length with its specific type.+(If you really wanted to leave things more polymorphic, you would need+to engage in TypeCast.)++Providing a specific Apply instance for (.) is not necessary, strictly+necessary. We could try to exploit the normal function instance for+Apply.++Let me recall that one here for convenience:++>instance Apply (x -> y) x y+> where+>  apply f x = f x++Let me also recall the hFoldr instances:++>class HList l => HFoldr f v l r | f v l -> r+> where+>  hFoldr :: f -> v -> l -> r++>instance HFoldr f v HNil v+> where+>  hFoldr _ v _ = v++>instance ( HFoldr f v l r+>         , Apply f (e,r) r'+>         )+>      => HFoldr f v (HCons e l) r'+> where+>  hFoldr f v (HCons e l) = apply f (e,hFoldr f v l)+++To fit in (.), we would flip and uncurry it.+So we could try:++comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++This wouldn't work.+The trouble is the required polymorphism of the first argument of+hFoldr.+The type of that argument as such is polymorphic.+However, this polymorphism does not survive type class parameterization.+You see this by looking at the HCons instance of HFoldr.+The different occurrences of "f" would need to be used at different+types.+This would only work if the type class parameter f were instantiated by+the polymorphic type of (uncurry (flip (.))). (And even then we may need+something like TypeCast.)++What you can do is define a dedicated *type code* for composition.++comp  = hFoldr (undefined::Comp) (id::Int -> Int) test++data Comp++instance Apply Comp (x -> y,y -> z) (x -> z)+ where+  apply _ (f,g) = g . f+++Ralf+++> -----Original Message-----+> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe-+> bounces@haskell.org] On Behalf Of Greg Buchholz+> Sent: Sunday, November 06, 2005 7:01 PM+> To: haskell-cafe@haskell.org+> Subject: [Haskell-cafe] Type classes and hFoldr from HList+>+>+>   I was playing around with the HList library from the paper...+>+>     Strongly typed heterogeneous collections+>     http://homepages.cwi.nl/~ralf/HList/+>+> ...and I thought I'd try to fold the composition function (.) through+a+> heterogeneous list of functions, using hFoldr...+>+> >{-# OPTIONS -fglasgow-exts #-}+> >{-# OPTIONS -fallow-undecidable-instances #-}+> >+> >import CommonMain+> >+> >main = print $ comp "abc"+> >+> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons+length+> HNil))+> >+> >comp = hFoldr (.) id test+> >+> >instance Apply (a -> b -> c -> d) (a, b) (c -> d)+> >    where+> >        apply f (a,b) = f a b+>+> ...but it fails with the following type error...+>+> ]Compiling Main             ( compose.hs, interpreted )+> ]+> ]compose.hs:10:7:+> ]    No instances for (Apply ((b -> c) -> (a -> b) -> a -> c)+> ]                            (Int -> Int, r)+> ]                            ([Char] -> a3),+> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) (Int ->+Int,+> r1) r,+> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] ->+> Int, a1 ->a1) r1)+> ]      arising from use of `hFoldr' at compose.hs:10:7-12+> ]    Probable fix:+> ]      add an instance declaration for (Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ]                                             (Int -> Int, r)+> ]                                             ([Char] -> a3),+> ]                                       Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ](Int -> Int, r1) r,+> ]                                       Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ]([a2] -> Int, a1 -> a1) r1)+> ]    In the definition of `comp': comp = hFoldr (.) id test+>+> ...Anyway, I couldn't quite tell whether I was using hFoldr+incorrectly,+> or if I needed to have more constraints placed on the construction of+> "test", or if needed some sort of type-level function that resolves...+>+> Apply ((b -> c) -> (a -> b) -> a -> c)+>+> ...into (a -> c), or something else altogether.  I figured someone+might+> be able to help point me in the right direction.++-}
+ examples/HListExample/OverloadedLabels.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedLabels, TypeOperators, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes, PolyKinds, TypeApplications, DataKinds #-}+module HListExample.OverloadedLabels where++import Data.HList.CommonMain+import GHC.OverloadedLabels+import Control.Lens+import Data.HList.Labelable+import Properties.Common+import Test.Hspec+import GHC.TypeLits++{- | -XOverloadedLabels expands #foo into `hLens' (Label :: Label "foo")`+++Not in Data.HList.Labelable because it would overlap other uses of IsLabel+-}+instance (Labelable x r s t a b, x ~ x_,+    lens ~ ((a `p` f b) `to` (r s `p` f (r t))),+    ty ~ LabelableTy r,+    LabeledOpticF ty f,+    LabeledOpticP ty p,+    LabeledOpticTo ty x to +    ) => IsLabel x_ lens where+   fromLabel = hLens' (Label :: Label x)+++{- | hLens' where the `x` type parameter must be supplied by -XTypeApplications.+In other words these are all equivalent:++> hLens' (Label :: Label "abc")+> hLens' (Label @"abc")+> hL @"abc"+> `abc -- HListPP+ +-}+hL :: forall x r s t a b to p f.+     Labelable x r s t a b =>+     LabeledOptic x r s t a b +hL = hLens' (Label :: Label x)+++r = #abc .==. 3 .*. emptyRecord+++mainOverloadedLabels = describe "-XOverloadedLabels" $ do+ it "lookup" $ do+    r ^. #abc `shouldShowTo` "3"+    r ^. hL @"abc" `shouldShowTo` "3"
+ examples/HListExample/Prism.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-} -- for pun+{-# LANGUAGE TemplateHaskell #-}+module HListExample.Prism where+++import Test.Hspec+import Properties.Common++import Data.HList.CommonMain+import Data.HList.Labelable (hLens')+import Control.Lens++-- generate left = Label :: Label "left"+makeLabels6 (words "left right up down")++--- define the Labelable labels manually+left_ = hLens' left+right_ = hLens' right+up_ = hLens' up+down_ = hLens' down++-- this definition is needed to decide what order+-- to put the fields in, as well as their initial types+r = [pun|right left up|] where+  left = 'a'+  right = 2 :: Int+  up = 2.3 :: Double++r2 = down_ .==. v .*. r++v = mkVariant left 'x' r++mainPrism = do+  it "inspect v with hPrism" $ do+    v ^? hPrism left `shouldShowTo` "Just 'x'"+    v ^? hPrism right `shouldBe` Nothing+    v ^? hPrism up `shouldBe` Nothing+    v2 ^? hPrism left `shouldShowTo` "Just ()"++  it "inspect v with hPrism through Labelable" $ do+    v ^? left_ `shouldShowTo` "Just 'x'"+    v ^? right_ `shouldBe` Nothing+    v ^? up_ `shouldBe` Nothing+    v2 ^? left_ `shouldShowTo` "Just ()"++  it "Setting the missing tag does nothing" $ do+    set right_ () v `shouldShowTo` "V{left='x'}"++    set _Right () (Left 'x') -- prisms for Either do the same thing+      `shouldShowTo` "Left 'x'"++  it "compose prism" $ do+    v3 ^? up_.up_ `shouldBe` Nothing+    v3 ^? left_ `shouldShowTo` "Just 'x'"++    v4 ^? left_.left_ `shouldShowTo` "Just \"leftleft\""++  it "compose lens.prism" $ do+    r2 ^? down_.left_ `shouldShowTo` "Just 'x'"+    r2 ^? down_.right_ `shouldBe` Nothing++    let du = down_.up_+    r2 ^? du `shouldBe` Nothing++  it "extension" $ do+    v5 ^? down_ `shouldBe` Just "hi"+    v6 ^? down_ `shouldBe` Just "hi"+    v7 ^? down_ `shouldBe` Nothing+    v7 ^? left_ `shouldBe` Just 'x'++  it "show" $ do+    vs `shouldShowTo`+        "Record{v=V{left='x'},\+        \v2=V{left=()},\+        \v2'=V{left=()},\+        \v3=V{left='x'},\+        \v4=V{left=V{left=\"leftleft\"}},\+        \v5=V{down=\"hi\"},\+        \v6=V{down=\"hi\"},\+        \v7=V{left='x'}}"++    -- works in ghci. Probably need -XExtendedDefaultRules+    -- wX `shouldShowTo` "V{x='a'}"+    -- wY `shouldShowTo` "V{y=2.5}"+    [wX,wY] `shouldShowTo` "[V{x='a'},V{y=2.5}]"++  -- :t wX+  -- > wX :: Variant '[Tagged "x" Char, Tagged "y" y]+  --+  -- > :t wY+  -- > wY :: Variant '[Tagged "x" x, Tagged "y" Double]+  --+  -- ghc doesn't need to decide on a type for values that+  -- have no influence on the final result+  it "type partly defined" $ do+    wX ^? hLens' (Label :: Label "x")+        `shouldShowTo` "Just 'a'"+    wY ^? hLens' (Label :: Label "y")+        `shouldShowTo` "Just 2.5"+  ++wX = mkVariant (Label :: Label "x") 'a' wProto+wY = mkVariant (Label :: Label "y") (2.5 :: Double) wProto++wProto = undefined :: Record+  '[Tagged "x" x, Tagged "y" y]++vs = [pun| v v2 v2' v3 v4 v5 v6 v7 |]++-- note that we can change the type of the 'x' field+-- from Char to ()+v2 = set (hPrism left) () v+++-- or with the "better" label+v2' = set left_ () v+++v3 = v & up_ .~ v & up_.up_ .~ "upup"+v4 = v & left_ .~ v & left_.left_ .~ "leftleft"+v5 = down .=. Just "hi" .*. v+v6 = down_ .==. Just "hi" .*. v+v7 = down .=. (Nothing :: Maybe String) .*. v
+ examples/HListExample/Pun.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+-- more examples for record puns+module HListExample.Pun where+import Data.HList.CommonMain++import Test.Hspec+import Properties.Common++makeLabels6 (words "a b c")+++r  = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord+r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord+++p1 ( (.!. b) -> (b@((.!. a) -> a))) = (a,b)++p2 [pun| b @ {a} |] = (a, b)++-- same as p2, but gives a warning+-- p3 [pun| b @ a |] = (a, b)++p4 [pun| b{a} |] = a -- b is not bound++-- adds `x' and `y' into a field called r+e1 = let x = 1; y = "hi" in [pun| r @ { x y } |]++-- updates the `c' field+e2 = let c = 1; y = "hi" in [pun| r @ { c y } |]++-- same as e1, but doesn't use a pre-existing r+e3 = let x = 1; y = "hi" in [pun| r { x y } |]+++mainPun = describe "pun quasiquoter" $ do+  it "pattern" $ do+        p1 r `shouldShowTo` "(3,Record{a=3})"+        p2 r `shouldShowTo` "(3,Record{a=3})"+        p4 r `shouldBe` 3++  it "expression" $ do+        e1 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\",c=\"c\",b=Record{a=3}}}"+        e2 `shouldShowTo` "Record{r=Record{c=1,y=\"hi\",b=Record{a=3}}}"+        e3 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\"}}"+
+ examples/HListExample/TIPTransform.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}++-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- +-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.++module HListExample.TIPTransform where++import Data.HList.CommonMain+import Data.Typeable++import Properties.Common+import Test.Hspec++-- We start with the examples++newtype MyVal = MyVal Int deriving (Show, Typeable)++-- or if no typeable, use+-- instance ShowLabel MyVal where showLabel _ = "MyVal"++tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP+++mainTIPTransform = describe "tipTransform" $ it "all" $ do+  tip1 `shouldShowTo` "TIPH[MyVal 20,1,True]"++  -- Update the Int component of tip1 to 2. The Int component must+  -- exist. Otherwise, it is a type error+  ttip (2::Int) tip1 `shouldShowTo`+        "TIPH[MyVal 20,2,True]"++  -- Negate the boolean component of tip1+  ttip not tip1 `shouldShowTo`+        "TIPH[MyVal 20,1,False]"++  -- Update the Int component from the values of two other components+  ttip (\(MyVal x) y -> x+y) tip1 `shouldShowTo`+    "TIPH[MyVal 20,21,True]"++  -- Update the MyVal component from the values of three other components+  ttip (\b (MyVal x) y -> MyVal $ if b then x+y else 0) tip1+        `shouldShowTo`+        "TIPH[MyVal 21,1,True]"++  -- The same but with the permuted argument order.+  -- The order of arguments is immaterial: the values will be looked up using+  -- their types+  ttip (\b y (MyVal x)-> MyVal $ if b then x+y else 0) tip1+        `shouldShowTo`+        "TIPH[MyVal 21,1,True]"++-- The implementation+-- part of HList proper now
+ examples/HListExample/TIPTransformM.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}  -- !TF+-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- The monadic version.+-- This file contains two versions of the code.+-- The comments -- !Simple and -- !TF distinguish the versions+--+-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.+-- In March 2010, Andrew Frank extended the problem for monadic operations.+-- This is the monadic version of TIPTransform.hs in the present directory.+++module HListExample.TIPTransformM where++import Data.HList.CommonMain+import Data.Typeable+import Control.Monad.Identity+import Control.Monad.Writer++import Test.Hspec+import Properties.Common++-- We start with the examples++newtype MyVal = MyVal Int deriving (Show,Typeable)++-- A specialized version of return for the Identity monad.+-- It is needed only for the Simple version of the code,+-- to tell the type checker the monad in which the computation is+-- taking place.+-- For the TF version of the code, we can use the ordinary return+-- in place of retI.+retI :: a -> Identity a+retI = return++-- A sample TIP+tip1 = MyVal 20 .*. (1::Int) .*. True .*. (3.5::Float) .*. emptyTIP+-- TIP (HCons (MyVal 20) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Update the Int component of tip1 to 2. The Int component must+-- exist. Otherwise, it is a type error+-- tip2 = runIdentity $ ttipM (retI (2::Int)) tip1 -- !Simple+tip2 = runIdentity $ ttipM (return (2::Int)) tip1  -- !TF+-- TIP (HCons (MyVal 20) (HCons 2 (HCons True (HCons 3.5 HNil))))+++-- Negate the boolean component of tip1+-- tip3 = runIdentity $ ttipM (retI . not) tip1 -- !Simple+tip3 = runIdentity $ ttipM (return . not) tip1      -- !TF+-- TIP (HCons (MyVal 20) (HCons 1 (HCons False (HCons 3.5 HNil))))++-- Update the Int component from the values of two other components+tip4 = runIdentity $ ttipM (\(MyVal x) y -> retI $ x+y) tip1+-- TIP (HCons (MyVal 20) (HCons 21 (HCons True (HCons 3.5 HNil))))++-- Update the MyVal component from the values of three other components+tip5 = runIdentity $ +       ttipM (\b (MyVal x) y -> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- The same but with the permuted argument order.+-- The order of arguments is immaterial: the values will be looked up using+-- their types+tip5' = runIdentity $ +        ttipM (\b y (MyVal x)-> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Andrew Frank's test+-- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil)))))+tip6 :: IO (TIP (TagR [MyVal,Int,Bool, Float]))+tip6 = ttipM op6 tip1++op6 :: MyVal -> Bool -> IO MyVal+op6 (MyVal x) b = do+                let m = if b then MyVal (x `div` 4) else MyVal (x * 4)+                putStrLn $ "MyVal is now " ++ show m+                            -- ==>> MyVal 5+                return m+-- TIP (HCons (MyVal 5) (HCons 1 (HCons True (HCons 3.5 HNil))))+++op6w :: MyVal -> Bool -> Writer String MyVal+op6w (MyVal x) b = do+                let m = if b then MyVal (x `div` 4) else MyVal (x * 4)+                tell ("MyVal is now " ++ show m)+                            -- ==>> MyVal 5+                return m+++{-  -- !Simple+-- The Simple implementation+-- The drawback is the need to let the type checker know the monad in which the+-- computations take place. That is why we had to use retI in the above+-- code, which is a specialized version of return for the Identity monad. +-- In op6, the presence of putStrLn unambiguously specified the monad, viz. IO,+-- so no special return are required.++class Monad m => TransTIPM m op db where+    ttipM :: op -> db -> m db++-- If the operation is the computation in the desired monad,+-- the type of the computation must match an element of TIP.+instance (Monad m,+	  HTypeIndexed db, HUpdateAtHNat n op db db, HType2HNat op db n)+    => TransTIPM  m (m op) (TIP db) where+    ttipM op db = do+                     op' <- op+		     return $ tipyUpdate op' db++-- If op is not a computation in the desired monad m, +-- it must be a function. Look up its argument in a TIP and recur.+instance (Monad m, HOccurs arg db, TransTIPM m op db)+    => TransTIPM m (arg -> op) db where+    ttipM f db = ttipM (f (hOccurs db)) db+-} -- !Simple++-- {- -- !TF+-- Moved to TIP.hs+-- -} -- !TF++mainTTIPM = describe "ttipM" $ it "all" $ do+  tip1 `shouldShowTo` "TIPH[MyVal 20,1,True,3.5]"+  tip2 `shouldShowTo` "TIPH[MyVal 20,2,True,3.5]"+  tip3 `shouldShowTo` "TIPH[MyVal 20,1,False,3.5]"+  tip4 `shouldShowTo` "TIPH[MyVal 20,21,True,3.5]"+  tip5 `shouldShowTo` "TIPH[MyVal 21,1,True,3.5]"+  let tip6w = runWriter (ttipM op6w tip1)+  fst tip6w `shouldShowTo` "TIPH[MyVal 5,1,True,3.5]"+  snd tip6w `shouldBe` "MyVal is now MyVal 5"+
+ examples/Properties.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# OPTIONS_GHC -freduction-depth=100 #-}+#else+{-# OPTIONS_GHC -fcontext-stack=100 #-}+#endif+{-# OPTIONS_GHC -fno-warn-deprecations #-} -- ghc-7.8 has no Typeable (x :: Symbol), so use OldTypeable+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Description: quickcheck tests+--+-- Many of the tests here use quickcheck. The lengths of the hlists+-- involved exhaustively cover a small range, while the elements+-- are random samples.+module Main where++import Test.Hspec++import Properties.LengthDependentSplice+import Properties.LengthIndependent+import Properties.KW++main = hspec $ do+   hl0+   hl1_2_3+   kwSpecs
+ examples/Properties/Common.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+module Properties.Common where++import Data.HList.CommonMain+import Test.QuickCheck+import Data.Array.Unboxed+import Data.HList.Variant+import Data.Monoid+import Data.Semigroup+import Control.Lens+import Control.Applicative+import GHC.TypeLits (Symbol)+import Language.Haskell.TH++#if MIN_VERSION_hspec_expectations(0,8,0)+import Test.Hspec.Expectations (shouldBe, shouldReturn, Expectation, HasCallStack)+#else+import Test.Hspec.Expectations (shouldBe, shouldReturn, Expectation)+import GHC.Exts (Constraint)+type HasCallStack = (() :: Constraint)+#endif++hListT :: [TypeQ] -> TypeQ+hListT = foldr (\a b -> [t| $a ': $b |]) promotedNilT++hListE :: [ExpQ] -> ExpQ+hListE = foldr (\a b -> [| $a `HCons` $b |]) [| HNil |]++hNatE :: Int -> ExpQ+hNatE n = foldr appE [| hZero |] (replicate n [| hSucc |])++hNatT :: Int -> TypeQ+hNatT n = foldr appT [t| HZero |] (replicate n [t| HSucc |])+++lx = Label :: Label "x"+ly = Label :: Label "y"+lz = Label :: Label "z"++data BinF b = BinF (b -> b -> b)++instance (bb ~ (b, b), b ~ b') => ApplyAB (BinF b') bb b where+    applyAB (BinF f) = uncurry f+++-- | A more general type than @===@ used to+-- ensure that both sides can infer the same type+eq :: (Show a, Show b, HCast a b, HCast b a, Eq a, Eq b) => a -> b -> Property+eq x y = hCast x === Just y .&&. Just x === hCast y+infix 4 `eq`+++shouldShowTo :: (HasCallStack, Show a) => a -> String -> Expectation+shouldShowTo x y = show x `shouldBe` y+infixr 0 `shouldShowTo`++shouldReturnShowTo :: (HasCallStack, Show a) => IO a -> String -> Expectation+shouldReturnShowTo x y = fmap show x `shouldReturn` y+infixr 0 `shouldReturnShowTo`++data HSuccF = HSuccF++instance (psn ~ Proxy (HSucc n),+        pn ~ Proxy n) => ApplyAB HSuccF pn psn where+    applyAB _ = hSucc+++data HSplitAtAppend l = HSplitAtAppend (HList l)+instance (pn ~ Proxy n,+          HSplitAt n l a b,+          HAppend (HList a) (HList b),+          y ~ HAppendR (HList a) (HList b)) => ApplyAB (HSplitAtAppend l) pn y where+    applyAB (HSplitAtAppend l) n = case hSplitAt n l of+                                     (a,b) -> hAppend a b++++data ConstTrue+instance HEqByFn ConstTrue+instance HEqBy ConstTrue x y True++data ConstFalse+instance HEqByFn ConstFalse+instance HEqBy ConstFalse x y False+++instance Arbitrary a => Arbitrary (Tagged t a) where+    arbitrary = fmap Tagged arbitrary++instance Arbitrary (HList '[]) where+    arbitrary = return HNil++instance (Arbitrary x, Arbitrary (HList xs)) => Arbitrary (HList (x ': xs)) where+    arbitrary = do+      x <- arbitrary+      xs <- arbitrary+      return $ x `HCons` xs++instance (Arbitrary x, Arbitrary (Variant (Tagged t y ': ys)),+          HExtend (Tagged s (Maybe x)) (Variant (Tagged t y ': ys)),+          HNat2Integral (HLength ys))+        => Arbitrary (Variant (Tagged s x ': Tagged t y ': ys)) where+    arbitrary = do+      let nys = hNat2Integral (Proxy :: Proxy (HLength ys))+      x :: Maybe x <- frequency [ (1, Just <$> arbitrary), (nys+1, return Nothing) ]+      yys :: Variant (Tagged t y ': ys) <- arbitrary+      return $ Tagged x .*. yys++instance Arbitrary z => Arbitrary (Variant '[Tagged t z]) where+    arbitrary = do+      z <- arbitrary+      return $ mkVariant1 Label z++instance (CoArbitrary x, CoArbitrary (Variant (y ': z)),+         HNat2Integral n, n ~ HLength (y ': z)) => CoArbitrary (Variant (x ': y ': z)) where+    coarbitrary v = case splitVariant1' v of+          Left x -> variant (hNat2Integral (Proxy :: Proxy n) :: Int) . coarbitrary x+          Right v' -> coarbitrary v'++instance (CoArbitrary v, Unvariant '[Tagged t v] v) => CoArbitrary (Variant '[Tagged t v]) where+    coarbitrary v = coarbitrary (unvariant v)++-- | This type is used to make unique types with two members.+--+-- > (BoolN True :: BoolN "x") /= (BoolN True :: BoolN "y")+--+-- is a type error+newtype BoolN (n :: Symbol) = BoolN Bool+  deriving (Eq,CoArbitrary,Arbitrary,Show,Read,Ord)++boolN next = simple $ iso (\(BoolN x) -> x) BoolN next++instance Monoid (BoolN n) where+    mempty = BoolN (getAll mempty)+#if __GLASGOW_HASKELL__ <= 906+    mappend (BoolN x) (BoolN y) = BoolN (getAll (mappend (All x) (All y)))++instance Semigroup (BoolN n) where (<>) = mappend+#else++instance Semigroup (BoolN n) where+  (BoolN x) <> (BoolN y) = BoolN (getAll (mappend (All x) (All y)))+#endif++#if !MIN_VERSION_QuickCheck(2,9,0)+instance Arbitrary (Identity (BoolN n)) where+    arbitrary = fmap return arbitrary+#endif+++data HSortF = HSortF+instance (x ~ Record xs,+          y ~ Record ys,+          HRLabelSet ys,+          HSort xs ys) => ApplyAB HSortF x y where+  applyAB _ (Record x) = mkRecord (hSort x)
+ examples/Properties/KW.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+module Properties.KW where+++import Properties.Common+import Test.QuickCheck+import Data.HList.CommonMain+import Test.Hspec+++kwSpecs = describe "kw" $ do+    {- with NoMonoLocalBinds+     - /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:59:15: error:ghc: panic! (the 'impossible' happened)+  (GHC version 8.0.2 for x86_64-unknown-linux):+	No skolem info: k_aqoh[sk]++        with MonoLocalBinds, I think the error is the same as in earlier versions++        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:62:15: error:+            • Couldn't match type ‘'[Tagged "x" (BoolN "x")]’ with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR (Tagged "x" (BoolN "x")) (Record '[])+            • In the first argument of ‘f2’, namely+                ‘(lx .=. x2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (lx .=. x2 .*. emptyRecord)’+              In the expression: f2 (lx .=. x2 .*. emptyRecord) `eq` f1 x2 y+                     +        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:63:15: error:+            • Couldn't match type ‘'[Tagged "y" (BoolN "y")]’ with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR (Tagged "y" (BoolN "y")) (Record '[])+            • In the first argument of ‘f2’, namely+                ‘(ly .=. y2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (ly .=. y2 .*. emptyRecord)’+              In the expression: f2 (ly .=. y2 .*. emptyRecord) `eq` f1 x y2+                     +        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:64:15: error:+            • Couldn't match type ‘'[Tagged "x" (BoolN "x"),+                                     Tagged "y" (BoolN "y")]’+                             with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR+                               (Tagged "x" (BoolN "x")) (Record '[Tagged "y" (BoolN "y")])+            • In the first argument of ‘f2’, namely+                ‘(lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’+              In the expression:+                f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord) `eq` f1 x2 y2+                     +        /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:65:15: error:+            • Couldn't match type ‘'[Tagged "y" (BoolN "y"),+                                     Tagged "x" (BoolN "x")]’+                             with ‘'[]’+              Expected type: Record '[]+                Actual type: HExtendR+                               (Tagged "y" (BoolN "y")) (Record '[Tagged "x" (BoolN "x")])+            • In the first argument of ‘f2’, namely+                ‘(ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’+              In the first argument of ‘eq’, namely+                ‘f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’+              In the expression:+                f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2++-}+    it "f1" $ property $ do+      (f1 :: BoolN "x" -> BoolN "y") <- arbitrary+      x :: BoolN "x" <- arbitrary+      x2 :: BoolN "x" <- arbitrary+      let f2 (Label :: Label "x") x () = f1 x+          f = f2 .*. recToKW [pun| x |]+      return $ conjoin+        [ kw f lx x2 () `eq` f1 x2,+          kw f () `eq` f1 x ]++    -- a function of two arguments can be made into a keyword function+    it "f2" $ property $ do+      (f1 :: BoolN "x" -> BoolN "y" -> BoolN "z") <- arbitrary+      x :: BoolN "x" <- arbitrary+      x2 :: BoolN "x" <- arbitrary+      y :: BoolN "y" <- arbitrary+      y2 :: BoolN "y" <- arbitrary++      let f2 (_ :: Label "x") x (_ :: Label "y") y () = f1 x y+          f = f2 .*. recToKW [pun| x y |]++      return $ conjoin+        [ kw f lx x2 ly y2 () `eq` f1 x2 y2,+          kw f ly y2 lx x2 () `eq` f1 x2 y2,+          kw f ly y2 () `eq` f1 x y2,+          kw f lx x2 () `eq` f1 x2 y,+          kw f () `eq` f1 x y ]++    -- alternatively, a function taking a record is pretty much+    -- a keyword argument. Error messages for missing keywords+    -- are a bit worse (blame hRearrange')+    it "f2Alt" $ property $ do+      (f1 :: BoolN "x" -> BoolN "y" -> BoolN "z") <- arbitrary+      x :: BoolN "x" <- arbitrary+      x2 :: BoolN "x" <- arbitrary+      y :: BoolN "y" <- arbitrary+      y2 :: BoolN "y" <- arbitrary++      let addDef new = hRearrange (Proxy :: Proxy [Label "x", Label "y"]) (new .<++. [pun| x y |])+          f2 (addDef  -> [pun| (x y) |]) = f1 x y+      return $ conjoin+        [ f2 emptyRecord `eq` f1 x y,+          f2 (lx .=. x2 .*. emptyRecord) `eq` f1 x2 y,+          f2 (ly .=. y2 .*. emptyRecord) `eq` f1 x y2,+          f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord) `eq` f1 x2 y2,+          f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2+        ]+
+ examples/Properties/LengthDependent.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+-- NOTE:+--+-- To be able to compile with ghc-7.6 functions like foo are sometimes+-- called+--+-- $(varE 'foo) because this prevents ghc-7.6 from failing to typecheck+-- the expression (which fails because the number of elements in the+-- supplied HList isn't known until Properties.LengthDependentSplice)+module Properties.LengthDependent where++#if MIN_VERSION_base(4,9,0)+import qualified Data.Kind as DK+#endif++import Data.HList.HSort (hMSortBy)+import Data.HList.Variant (eqVariant)+import Data.HList.Record (hZipRecord2)+import Data.HList.HList (hAppend')+import Data.HList.CommonMain+++#if MIN_VERSION_template_haskell(2,17,0)+import Language.Haskell.TH.Lib.Internal hiding (doE)+import Language.Haskell.TH (Name, mkName, doE)+#else+import Language.Haskell.TH+#endif++import Test.QuickCheck+import Properties.Common+import Test.Hspec+import Control.Lens+import Data.List (sort,permutations)+import Data.Monoid++hlN :: Int -> ExpQ+hlN n = [| \proxy -> hSequence+              $ $(varE 'hReplicate) $(hNatE n)+                    (arbitrary `asTypeOf` return proxy) |]++-- > $(rKN id n) (undefined :: t) :: Arbitrary t => Gen (HList [Record t1, Record t2, ... ])+--+-- where+--    t1 ~ '[Tagged 1 t, Tagged 2 t, Tagged 3 t, ... , Tagged n t]+--    t2 ~ '[Tagged 2 t, Tagged 1 t, Tagged 3 t, ... , Tagged n t]+--    tN ~ nth permutation of t1+rKN :: (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n+    -> Int+    -> ExpQ+rKN = rKN' (litT . numTyLit)+++rKN' ::+    (Integer -> TypeQ) -- ^ make the label+    -> (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n+    -> Int+    -> ExpQ+rKN' mkLab takeK n = [| \proxy -> do+        $(recs [| arbitrary `asTypeOf` return proxy |])+            `asTypeOf` return $sig+         |]+    where sig = [| undefined |] `sigE` quantify [t| HList $(hListT rss) |]+++          ti :: Int -> Name+          ti i = mkName ("t" ++ show i)++          recs gen = doE $+               [ bindS (varP (ti i)) gen   | i <- [1 .. n] ] +++               [ noBindS+                  [| return $ $(hListE+                      [ [| unlabeled # $(hListE (map (varE . ti) is)) |]+                        | is <- takeK $ permutations [1 .. n] ])+                   |]+                ]++          myForallT :: [Name] -> TypeQ -> TypeQ+#if MIN_VERSION_template_haskell(2,17,0)+          myForallT ns = forallT [ plainInvisTV n inferredSpec | n <- ns ] (cxt [])+#else+          myForallT ns = forallT (map plainTV ns) (cxt [])+#endif+          quantify :: TypeQ -> TypeQ+          quantify = myForallT [ mkName ("x" ++ show i) | i <- [1 .. n]]+++          rss :: [TypeQ]+          rss = takeK $+#if MIN_VERSION_base(4,9,0)+                [ [t| (Record :: [DK.Type] -> DK.Type) $(hListT (map taggedN ns)) |]+#else+                [ [t| (Record :: [*] -> *) $(hListT (map taggedN ns)) |]+#endif+                   | ns <- permutations [1 .. fromIntegral n] ]++          -- taggedN 1 == [t| Tagged 1 x1 |]+          taggedN :: Integer -> TypeQ+          taggedN i = [t| Tagged $(mkLab i) $(varT (mkName ("x"++show i))) |]++-- | > $(rN n) :: a -> Record [Tagged 1 a, Tagged 2 a, ... Tagged n a]+rN n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN (take 1) n) proxy |]+++-- | > $(rNstr n) :: a -> Record [Tagged "1" a, Tagged "2" a, ... Tagged n a]+rNstr n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN' (litT . strTyLit . show) (take 1) n) proxy |]++vN :: Int -> ExpQ+vN n = [| \proxy -> do+       let toV :: Gen (Record a) -> Variant a+           toV = undefined+       v <- arbitrary+       return (v `asTypeOf` toV ($(rN n) proxy))+  |]++-- specs for 1 HList of length >= 1+hl1 n1 = [| do+  let -- | generate a HList of length nMax containing elements+      -- selected from there+      genHL proxy = $(hlN n1) proxy++  it "hConcat/hAppend" $+      property $ do+        x <- genHL True+        y <- genHL True+        return $ conjoin [$(varE 'hConcat) ($(varE 'hBuild) x y) == hAppend x y,+                          $(varE 'hConcat) ($(varE 'hBuild) x y) == hAppend' x y,+                          $(varE 'hConcat) (hBuild x) == x]++  it "partition" $+      property $ do+        x <- genHL True+        return $ conjoin+          [hPartitionEq (Proxy :: Proxy ConstTrue) (Proxy :: Proxy ()) x `eq` (x, HNil),+           hPartitionEq (Proxy :: Proxy ConstFalse) (Proxy :: Proxy ()) x `eq` (HNil, x)]+++  it "listAsHList/hList2List" $ do+      property $ do+        x <- genHL True+        return $ conjoin [+            review listAsHList x `eq` hList2List x,+            review listAsHList' x `eq` hList2List x]++  it "read/show" $+      property $ do+        xs <- genHL True+        return $ read (show xs) == xs++  it "hLength/hReplicate" $+      property $ do+        xs <- genHL True+        return $ hNat2Integral (hLength xs) == hNat2Integral $(hNatE n1)++  it "hInits last id" $+      property $ do+        xs <- genHL True+        return $ $(varE 'hLast) (hInits xs) == xs++  it "hInits head empty" $+      property $ do+        xs <- genHL True+        return $ hHead (hInits xs) == HNil++  it "hTails head id" $+      property $ do+        xs <- genHL True+        return $ hHead (hTails xs) == xs++  it "hTails last empty" $+      property $ do+        xs <- genHL True+        return $ $(varE 'hLast) (hTails xs) == HNil++  it "hScanr equals scanr" $+      property $ do+        f <- arbitrary+        a <- arbitrary+        hl <- genHL True+        return $ hList2List (hScanr (BinF f) a hl)+                == scanr f a (hList2List hl)++  it "hFoldr equals foldr" $+      property $ do+        f <- arbitrary+        a <- arbitrary+        hl <- genHL True+        return $ hFoldr (BinF f) a hl == foldr f a (hList2List hl)++  it "hFoldr1 equals foldr1" $+      property $ do+        f <- arbitrary+        hl <- genHL True+        return $ hFoldr1 (BinF f) hl == foldr1 f (hList2List hl)++  it "hFoldl equals foldl" $+      property $ do+        f <- arbitrary+        a <- arbitrary+        hl <- genHL True+        return $ hFoldl (BinF f) a hl == foldl f a (hList2List hl)++  it "hSplitAt" $+      property $ do+        hl <- genHL True+        let n = hLength hl+            l = hList2List hl+        -- hList2List doesn't like empty lists, and hMapOut id needs+        -- annotations, so the following cases are easier to construct+        -- than a direct comparison with splitAt+        return $ conjoin+          [ case hSplitAt hZero hl of+              (hNil, hl') -> (hNil `eq` HNil) .&&. (hl' `eq` hl),+            case $(varE 'hSplitAt) n hl of+              (hl', hNil) -> (hNil `eq` HNil) .&&. (hl' `eq` hl),++            $(varE 'hMap) (HSplitAtAppend hl) ($(varE 'hIterate) (hSucc n) HSuccF hZero) `eq` $(varE 'hReplicate) (hSucc n) hl ,+            map (\n -> uncurry (++) $ splitAt n l) [0 .. length l]      === replicate (length l+1) l+              -- the equivalent list-version+           ]++  it "hAppend empty is identity" $+      property $ do+        x <- genHL (BoolN True :: BoolN "x")+        return $ all (== x) [$(varE 'hAppend) HNil x, $(varE 'hAppend) x HNil]++  it "hReverse involution" $ do+      property $ do+        x <- genHL True+        return $ x == $(varE 'hReverse) (hReverse x)++  it "hReverse does nothing for ()" $+      let xs = $(varE 'hReplicate) $(hNatE n1) ()+      in xs `shouldBe` $(varE 'hReverse) xs++  it "hInit == tail on reverse" $+      property $ do+        let hInitReference xs = hReverse (hTail (hReverse xs))+        hl <- genHL True+        return $ $(varE 'hInit) hl `eq` $(varE 'hInitReference) hl++  it "hList2List/list2HList" $ property $ do+      x <- genHL True+      return $ list2HList (hList2List x) === Just x++  it "hMap equals map" $ property $ do+      f  <- arbitrary+      hl <- genHL True+      return $ hList2List (hMap f hl) `eq` map (f :: Bool -> BoolN "f") (hList2List hl)++  it "hZip" $ property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "y")+      return $ hList2List (hZip x y) `eq` hList2List x `zip` hList2List y++  it "hZipRecord" $ property $ do+      x <- $(rN n1) (BoolN True :: BoolN "x")+      y <- $(rN n1) (BoolN True :: BoolN "y")+      let r1 = hZip x y ^. unlabeled & hList2List+          r2 = hZipRecord2 x y ^. unlabeled & hList2List+          r_ = hList2List (x ^. unlabeled) `zip` hList2List (y ^. unlabeled)++      return $ conjoin [+          r1 `eq` r_,+          r2 `eq` r_,+          hUnzip (hZip x y) `eq` (x,y) ]++  it "hZip/hUnZip" $ property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "y")+      return $ hUnzip (hZip x y) == (x,y)++  it "hUnzip/hZip" $ property $ do+      xy <- genHL (BoolN True :: BoolN "x", BoolN True :: BoolN "y")+      let (x,y) = hUnzip xy+      return $ xy `eq` hZip x y++  it "hUnzip2/hZip2" $ property $ do+      xy <- genHL (BoolN True :: BoolN "x", BoolN True :: BoolN "y")+      let (x,y) = hUnzip2 xy+      return $ xy `eq` hZip2 x y++  -- XXX doesn't work with ghc-7.10.1+  -- (should be fixed for 7.10.2)+  it "hZip/hZip2" $ property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "y")+      return $ hZip x y `eq` hZip2 x y++  -- lots of duplication, not sure if it's worth factoring out+  it "HList monoid unit" $+    property $ do+      x <- genHL (BoolN True :: BoolN "x")+      return $ conjoin+        [ x === (x `mappend` mempty),+          x === (mempty `mappend` x) ]+  it "Record monoid unit" $+    property $ do+      x <- $(rN n1) (BoolN True :: BoolN "x")+      return $ conjoin+        [ x === (x `mappend` mempty),+          x === (mempty `mappend` x) ]+  it "Variant monoid unit" $+    property $ do+      x <- $(rN n1) (BoolN True :: BoolN "x")+      return $ conjoin+        [ x === (x `mappend` mempty),+          x === (mempty `mappend` x) ]++  -- lots of duplication, not sure if it's worth factoring out+  it "HList monoid assoc" $+    property $ do+      x <- genHL (BoolN True :: BoolN "x")+      y <- genHL (BoolN True :: BoolN "x")+      z <- genHL (BoolN True :: BoolN "x")+      return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z))+  it "Record monoid assoc" $ property $ do+    x <- $(rN n1) (BoolN True :: BoolN "x")+    y <- $(rN n1) (BoolN True :: BoolN "x")+    z <- $(rN n1) (BoolN True :: BoolN "x")+    return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z))+  it "Variant monoid assoc" $ property $ do+    x <- $(vN n1) (BoolN True :: BoolN "x")+    y <- $(vN n1) (BoolN True :: BoolN "x")+    z <- $(vN n1) (BoolN True :: BoolN "x")+    return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z))++  it "Variant == /eqVariant" $ property $ do+    x <- $(vN n1) (BoolN True :: BoolN "x")+    y <- $(vN n1) (BoolN True :: BoolN "x")+    return $ conjoin [ eqVariant x y == (x == y),+                       (x == y) == (y == x) ]++  it "Variant ord" $ property $ do+    x <- $(vN n1) (BoolN True :: BoolN "x")+    y <- $(vN n1) (BoolN True :: BoolN "x")+    z <- $(vN n1) (BoolN True :: BoolN "x")+    let xyz = [x,y,z]+        s:ss = map sort (permutations xyz)+    return $ all (s ==) ss++#if __GLASGOW_HASKELL__ > 707 && __GLASGOW_HASKELL__ < 901+  -- ghc-7.6 has no ordering for Nat (only for HNat)+  it "hSort (the labels)" $ property $ do+    x <- $(rN n1) True+    let rx = x & from hListRecord %~ hReverse+    -- rN generates a record that has labels in ascending order already+    return $ conjoin [+         x `eq` (x  & from hListRecord %~ hSort),+         x `eq` (rx & from hListRecord %~ hSort),+         x `eq` (x  & from hListRecord %~ hMSortBy (Proxy :: Proxy HLeFn)),+         x `eq` (rx & from hListRecord %~ hMSortBy (Proxy :: Proxy HLeFn))+         ]++  -- restrict to lists of length 4 (since then the number of permutations+  -- is a manageable 24 not 120)+  it "hSort permutations" $ property $ do+    xs <- $(rKN id (min 4 n1)) True+    return $ all (== hHead xs) (hMapOut HSortF xs)++#endif++  it "hRenameLabel" $ property $ do+    r <- $(rN n1) True+    return $ conjoin+        $(listE [ [| hRenameLabel $ln lx r .!. lx === r .!. $ln |]+              | i <- [1 .. n1],+                let ln = [| Label :: Label $(litT (numTyLit (fromIntegral i))) |]+            ])+#if __GLASGOW_HASKELL__ < 901+  it "rearranged / hMapR" $ property $ do+    r <- $(rN n1) True+    let revR = r & from hListRecord %~ hReverse+        asT :: x -> As x+        asT _ = id+    -- hMap works on the reversed list+    return $ hMapR not r === (r & rearranged' . asT revR . unlabeled %~ hMap not)+#endif+++  it "hOccurs" $ property $ do+    w <- arbitrary :: Gen (BoolN "w")+    x <- genHL (BoolN True :: BoolN "x")+    y <- genHL (BoolN True :: BoolN "y")+    z <- genHL (BoolN True :: BoolN "z")+    let xyz = hConcat (hBuild x y z)+        hxyz = hEnd (hBuild (hHead x) (hHead y) (hHead z))++        -- -XNoMonoLocalBinds on ghc <= 7.10.4 allowed+        -- having one function+        hM1 v = hOccursMany xyz === hList2List v+        hM2 v = hOccursMany xyz === hList2List v+        hM3 v = hOccursMany xyz === hList2List v+    return $ conjoin+      [ hM1 x, hM2 y, hM3 z,+        hOccurs (hConcat (hBuild x (HCons w HNil) z)) === w,+        hOccursOpt xyz === (Nothing `asTypeOf` Just w)+        -- hProject hxyz === hBuild (hHead x) (hHead y)+       ]++ |]++hl2 n1 n2 = [| do+  it "splitVariant" $ property $ do+    x <- $(vN (n1 + n2)) True+    let testV :: forall n x yin yout.+               (Eq (Variant x),+                SplitVariant x yin yout,+                HSplitAt n x yin yout,+                ExtendsVariant yin x,+                ExtendsVariant yout x) =>+                Proxy n -> Variant x -> Bool+        testV n v = case $(varE 'splitVariant) v of+                      Left a -> extendsVariant (a :: Variant yin) == v+                      Right a -> extendsVariant (a :: Variant yout) == v+    return $ $(varE 'testV) $(hNatE n1) x+++  it "hAppend equals ++" $+    property $ do+      x <- $(hlN n1) True+      y <- $(hlN n2) True+      return $ hList2List (hAppend x y) === hList2List x ++ hList2List y++  it "hTranspose involution" $ property $ do+    x <- return (error "hTranspose involution") `asTypeOf` $(hlN n1) True+    xx <- $(hlN n2) x+    return $ $(varE 'hTranspose) ($(varE 'hTranspose) xx) === xx++  it "leftUnion / unionSR" $+    property $ do+      x <- $(rN n1) True+      y <- $(rN n2) True+      let asL r = r ^. unlabeled . to hList2List+          asLs (r1,r2) = (asL r1, asL r2)+          merge xs ys = xs ++ drop (length xs) ys+          mergeSym xs ys = (merge xs ys, merge ys xs)+          eqSorted (a,b) (c,d) = sort a === sort c .&&. sort b === sort d+      return $ conjoin [+        asL (x .<++. y) === asL x `merge` asL y,+        ($(varE '(.<++.)) x x) === x,+        ($(varE '(.<++.)) y y) === y,+        asLs (unionSR x y) `eqSorted` mergeSym (asL x) (asL y),+        (x `unionSR` x) === (x,x),+        (y `unionSR` y) === (y,y)]++    |]++hl3 n1 n2 n3 = [| do+  it "hAppend/hAppendList assoc" $+    property $ do+      x <- $(hlN n1) (BoolN True :: BoolN "x")+      y <- $(hlN n2) (BoolN True :: BoolN "y")+      z <- $(hlN n3) (BoolN True :: BoolN "z")+      return $ conjoin+#if __GLASGOW_HASKELL__ < 707+        [ $([| (x `hAppend` y) `hAppend` z |]) === $([| x `hAppend` (y `hAppend` z) |]),+          $([| (x `hAppendList` y) `hAppendList` z|]) === $([| x `hAppendList` (y `hAppendList` z)|])+        ]+#else+        [ ((x `hAppend` y) `hAppend` z) === (x `hAppend` (y `hAppend` z)),+          ((x `hAppendList` y) `hAppendList` z) === (x `hAppendList` (y `hAppendList` z))+        ]+#endif+  |]
+ examples/Properties/LengthDependentSplice.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 906+{-# OPTIONS_GHC -freduction-depth=100 #-}+#else+{-# OPTIONS_GHC -fcontext-stack=100 #-}+#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MonoLocalBinds #-} -- maybe it isn't necessary for everything?+module Properties.LengthDependentSplice where+import Properties.LengthDependent+import Language.Haskell.TH+import Test.Hspec++hl1_2_3 :: Spec+hl1_2_3 = $(doE $+        [ noBindS+               [| describe $(stringE (show n)) $(hl1 n) |]+            | n <- [1 .. 5]]+    ++ [ noBindS [| describe $(stringE (show (n1,n2))) $(hl2 n1 n2) |]+      | n1 <- [1 .. 2],+        n2 <- [1 .. 2] ]+    ++ [ noBindS [| describe $(stringE (show (n1,n2,n3))) $(hl3 n1 n2 n3) |]+      | n1 <- [0 .. 2],+        n2 <- [0 .. 1],+        n3 <- [0 .. 1],+        not $ all (==0) [n1,n2,n3] ]+  )
+ examples/Properties/LengthIndependent.hs view
@@ -0,0 +1,688 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+module Properties.LengthIndependent where+import Properties.Common+import Control.Lens+import Data.HList.CommonMain+import Test.Hspec+#if MIN_VERSION_QuickCheck(2,10,1)+import Test.QuickCheck hiding (Fun)+#else+import Test.QuickCheck+#endif+import Data.Monoid+import Data.Maybe+import Control.Applicative+import Control.Monad++import Data.Generics++makeLabels3 "lengthindependent" (words "lx_ ly_")+++-- | tests for a fixed length+hl0 = describe "0 -- length independent"  $ do+  hTuples++  it "listAsHList" $ property $ do+    (f :: Bool -> Bool) <- arbitrary+    let bools = [True,False]+        mapF (a `HCons` b `HCons` HNil) = f a `HCons` f b `HCons` HNil+        len3 = id :: As (HList '[a,b,c])+        len2 = id :: As (HList [a,b])+        len1 = id :: As (HList '[a])+    return $ conjoin+      [ (bools & listAsHList %~ mapF) `eq` map f bools,+        (bools & listAsHList' . len2 %~ hMap f ) `eq` map f bools,+        (bools & listAsHList' . len3 %~ hMap f ) `eq` ([] :: [Bool]),+        (bools & listAsHList' . len1 %~ hMap f ) `eq` ([] :: [Bool])]++  it "read0" $ read "H[]" `shouldBe` HNil++  it "Fun" $ property $ do+    let plusF = Fun (+1) :: Fun Num '()+    x :: Int <- arbitrary+    y :: Double <- arbitrary+    return $ hMap plusF (hBuild x y) === hEnd (hBuild (x+1) (y+1))++  it "Fun 2" $ property $ do+    let showSuccF = Fun (show . (+1)) :: Fun [Num,Show] String+    x :: Int <- arbitrary+    y :: Double <- arbitrary+    return $ hMapOut showSuccF (hBuild x y) === [ show (x+1), show (y+1)]++  it "Fun'" $ property $ do+    x :: Bool <- arbitrary+    return $ applyAB (Fun' read :: Fun' Read String) (show x) === x++  it "HComp" $ property $ do+    let f = Fun (+1) :: Fun Num '()+        g = Fun show :: Fun Show String+        gof = g `HComp` f++    x :: Int <- arbitrary+    y :: Double <- arbitrary++    let ref = [show (x+1), show (y+1)]++    return $ conjoin [+        hMapOut gof (hBuild x y) `eq` ref,+        hMapOut g (hMap f (hBuild x y)) `eq` ref ]++  it "toLabel 1" $+    case hCast (toLabel (hLens' lx)) of+      l -> True `const` (l `asTypeOf` Just lx)++  it "toLabel 2" $ case hCast (toLabel lx) of+      l -> True `const` (l `asTypeOf` Just lx)++  it "HCast is ==" $ property $ do+    x :: BoolN "x" <- arbitrary+    x' :: BoolN "x" <- arbitrary+    return $ (x == x') ==> (x `eq` x')++  it "HCast neq" $ property $ do+    x :: BoolN "x" <- arbitrary+    y :: BoolN "y" <- arbitrary+    return (expectFailure $ x `eq` y)++  let mkXYvariant = do+        (x :: Bool) <- arbitrary+        (my :: Maybe Bool) <- arbitrary+        return $ (ly .=. my .*. mkVariant1 lx x,+                  my)++  it "variant lookup/extend" $ do+    property $ do+      (v, my) <- mkXYvariant+      return $ conjoin [+          v .!. ly == my,+          v ^? hLens' ly == my,+          v ^? hPrism ly == my ]++  it "variant update" $ property $ do+    x :: Maybe (BoolN "x") <- arbitrary+    x' :: BoolN "x'" <- arbitrary+    y :: BoolN "y" <- arbitrary+    let v = lx .=. x .*. mkVariant1 ly y+        v' | isJust x = lx .=. Just x' .*. mkVariant1 ly y+           | otherwise = lx .=. Nothing .*. mkVariant1 ly y+    return $ conjoin [+        hUpdateAtLabel lx x' v === v',+        (v & hLens' lx .~ x') === v',+        (v & hPrism lx .~ x') === v']+++  it "unvariant" $ do+    property $ do+      (v, _) <- mkXYvariant+      return $ unvariant v == fromJust (msum [v .!. ly, v .!. lx])++  it "unvarianted" $ property $ do+    x :: Maybe Bool <- arbitrary+    y :: Bool <- arbitrary+    let v = lx .=. x .*. mkVariant1 ly y+        vUnitExpected = lx .=. (() <$ x) .*. mkVariant1 ly ()+        vUnit = v & unvarianted .~ ()+        vNot = lx .=. (not <$> x) .*. mkVariant1 ly (not y)+    return $ conjoin [+        v ^. unvarianted === fromMaybe y x,+        (v & unvarianted %~ not) === vNot,+        vUnit === vUnitExpected,+        vUnit ^. unvarianted === ()  ]++  it "HMapOutV" $ do+    property $ do+      (v, _) <- mkXYvariant+      return $ hMapOutV not v `eq` not (fromJust (msum [v .!. ly, v .!. lx]))++  it "zipVR" $ property $ do+    (f :: BoolN "x" -> BoolN "x'",+     g :: BoolN "y" -> BoolN "y'",+     b,x,y) <- arbitrary+    let p = lx .*. ly .*. emptyProxy+        v  | b = mkVariant lx x Proxy `asLabelsOf` p+           | otherwise = mkVariant ly y Proxy+        v' | b = mkVariant lx (f x) Proxy `asLabelsOf` p+           | otherwise = mkVariant ly (g y) Proxy++        fun = lx .=. f .*. ly .=. g .*. emptyRecord++    return $ zipVR fun v `eq` v'++  it "zipVariant" $ property $ do+    x1 :: Maybe (BoolN "x1") <- arbitrary+    x2 :: Maybe (BoolN "x2") <- arbitrary+    y1 :: BoolN "y1" <- arbitrary+    y2 :: BoolN "y2" <- arbitrary++    let v1 = lx .=. x1 .*. mkVariant1 ly y1+        v2 = lx .=. x2 .*. mkVariant1 ly y2++        vrT = Proxy :: Proxy '[ Tagged "x" (BoolN "x1", BoolN "x2"),+                                Tagged "y" (BoolN "y1", BoolN "y2") ]+        vr = case (x1,x2) of+               (Just a, Just b) -> Just $ mkVariant lx (a,b) vrT+               (Nothing, Nothing) -> Just $ mkVariant ly (y1,y2) vrT+               _ -> Nothing++    return $ zipVariant v1 v2 `eq` vr++  it "variant Eq" $ property $ do+    x1 :: Maybe (BoolN "x") <- arbitrary+    x2 :: Maybe (BoolN "x") <- arbitrary+    y1 :: BoolN "y" <- arbitrary+    y2 :: BoolN "y" <- arbitrary++    let v1 = lx .=. x1 .*. mkVariant1 ly y1+        v2 = lx .=. x2 .*. mkVariant1 ly y2+    return $ (v1 == v2) === (x1 == x2 && (isJust x1 || y1 == y2))+++  it "projectVariant" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    z <- arbitrary++    let vFull :: Variant [Tagged "a" (BoolN "a"),+                          Tagged "b" (BoolN "b"),+                          Tagged "c" (BoolN "c"),+                          Tagged "z" (BoolN "z")]+        vFull = a .*. b .*. c .*. mkVariant1 Label z++        isN x = isNothing (untag x)+        vZJ :: Variant '[Tagged "z" (BoolN "z")]+        vZJ = mkVariant1 Label z++        vZ | isN a, isN b, isN c = Just vZJ+           | otherwise = Nothing++    return $ conjoin [+       vFull ^? projected === vZ,+       -- XXX maybe projected can be made to work instead of projected'+       ((projected' # vZJ) `asTypeOf` vFull) ^? projected === Just vZJ+       ]++  it "variant/tic extend" $ do+    property $ do+      x :: BoolN "x" <- arbitrary+      my :: Maybe (BoolN "y") <- arbitrary+      let v = ly .=. my .*. mkVariant1 lx x+          tic1 = my .*. mkTIC1 x+      return $ conjoin+        [ -- v == tic1 ^. from typeIndexed,+          v^. typeIndexed == tic1+          ]++++  it "variant/typeIndexed" $ do+    property $ do+      x :: BoolN "x" <- arbitrary+      y :: Maybe (BoolN "y") <- arbitrary+      let v = ly .=. y .*. mkVariant1 lx x+      let tic = v ^. typeIndexed+      return $ conjoin+        [ v .!. ly === hOccurs tic,+          v .!. ly === tic ^? ticPrism,+          v .!. ly `eq` tic .!. (Label :: Label (BoolN "y")),++          v .!. lx === hOccurs tic,+          v .!. lx === tic ^? ticPrism,+          v .!. lx `eq` tic .!. (Label :: Label (BoolN "x"))+        ]++  it "Record/typeIndexed" $ do+    property $ do+      x :: BoolN "x" <- arbitrary+      y :: BoolN "y" <- arbitrary+      let r = ly .=. y .*. lx .=. x .*. emptyRecord+          tip = r ^. typeIndexed++          asX :: As (BoolN "x")+          asX = id+          asY :: As (BoolN "y")+          asY = id++      return $ conjoin+        [ r .!. lx === hOccurs tip,+          r .!. lx === tip ^. tipyLens,+          r .!. lx `eq` tip .!. (Label :: Label (BoolN "x")),++          -- two ways to apply 'not' to the 'x' field+          (r & hLens lx . boolN %~ not) `eq`+              (r & typeIndexed %~ ttip (asX . boolN %~ not)),++          -- and repeat everything for the other field+          r .!. ly === hOccurs tip,+          r .!. ly === tip ^. tipyLens,+          r .!. ly `eq` tip .!. (Label :: Label (BoolN "y")),+          (r & hLens ly . boolN %~ not) `eq`+              (r & typeIndexed %~ ttip (asY . boolN %~ not))+        ]++  -- other operations union, projection etc.+  it "Record lookup mixing labels" $ do+    property $ do+      v1 :: BoolN "v1" <- arbitrary+      v2 :: BoolN "v2" <- arbitrary+      v3 :: BoolN "v3" <- arbitrary+      let l1 = Label :: Label ()+          l2 = Label :: Label 2+          l3 = Label :: Label "3"+          p = Proxy :: Proxy '[Label (), Label 2 , Label "3"]++          p1 = consl1 $ l2 .*. l3 .*. emptyProxy++          -- HExtend doesn't support Label5+          consl1 :: Proxy x -> Proxy (Label () ': x)+          consl1 _ = Proxy++          r = hEndR (hBuild v1 v2 v3) `asLabelsOf` p+      return $ conjoin+        [ r.!.l1 `eq` v1,+          r.!.l2 `eq` v2,+          p1 `eq` p ]++  it "Record hLookupByLabelM" $ property $ do+    v :: BoolN "v" <- arbitrary+    w :: BoolN "v" <- arbitrary+    let r = [pun| v |]+    return $ conjoin+      [ hLookupByLabelM (Label :: Label "v") r w `eq` v,+        hLookupByLabelM (Label :: Label "w") r w `eq` w ]++  it "HOccurs HList" $ do+    property $ do+      x <- arbitrary+      return $ hOccurs (hEnd (hBuild x)) == (x :: Bool)++  it "HOccurs TIP" $ do+    property $ do+      x <- arbitrary+      return $ hOccurs (hEnd (hBuild x) ^. from tipHList) == (x :: Bool)++  it "HOccurs TIP inference" $+    hOccurs (HCons True HNil^. from tipHList)+      `eq` True++  it "tipyLens" $ property $ do+    u :: BoolN "u" <- arbitrary+    v :: BoolN "v" <- arbitrary+    w :: BoolN "w" <- arbitrary+    let r = tipHList # hBuild v w+    return $ conjoin+      [ (r & tipyLens %~ ( \ (_ :: BoolN "v") -> u)) `eq` tipHList # hBuild u w,+        (r & tipyLens %~ ( \ (_ :: BoolN "w") -> u)) `eq` tipHList # hBuild v u+        ]++  it "ttip 3" $ do+    property $ do+      f <- arbitrary+      (a :: BoolN "a") <- arbitrary+      (b :: BoolN "b") <- arbitrary+      (c :: BoolN "c") <- arbitrary+      let tp = a .*. b .*. c .*. emptyTIP+      return $ hOccurs (ttip f tp) == (f a b c :: BoolN "a")++  it "ttipM 3" $ do+    property $ do+      f <- arbitrary+      (a :: BoolN "a") <- arbitrary+      (b :: BoolN "b") <- arbitrary+      (c :: BoolN "c") <- arbitrary+      let tp = a .*. b .*. c .*. emptyTIP+      return $ hOccurs (runIdentity (ttipM f tp)) == (runIdentity (f a b c) :: BoolN "a")++  it "Show/Read instances" $ do+    show (hEnd (hBuild 1 2 3)) `shouldBe` "H[1,2,3]"++    let r = lx .=. 'x' .*. ly .=. "y" .*. emptyRecord+    show r `shouldBe` "Record{x='x',y=\"y\"}"+    read (show r) `shouldBe` r++    show (r ^. unlabeled . from tipHList) `shouldBe` "TIPH['x',\"y\"]"++    v <- return $ map ($ r) [mkVariant lx 'a', mkVariant ly "ly"]++    show v `shouldBe` "[V{x='a'},V{y=\"ly\"}]"+    read (show v) `shouldBe` v++#if __GLASGOW_HASKELL__ != 802 && __GLASGOW_HASKELL__ != 804+    -- ghc-8.2.1: typeIndexed' has: Couldn't match with  ‘*’ with ‘Symbol’+    -- probably a ghc bug as it (1) works in other version (2) works after in-lining+    show (map (^. typeIndexed') v) `shouldBe` "[TIC{char='a'},TIC{[Char]=\"ly\"}]"+#endif+    show (map (^. simple . typeIndexed . simple) v) `shouldBe` "[TIC{char='a'},TIC{[Char]=\"ly\"}]"++  it "Data instances gread/gshow" $ do+    property $ do+      a :: Maybe Bool <- arbitrary+      b :: Bool <- arbitrary+      let h = hEnd $ hBuild a b+          v = lx_ .=. a .*. mkVariant1 ly_ b+          r = (unlabeled # h) `asLabelsOf` pLabel3++          -- ghc-7.8 can't use pLabel5 (due to a lack of Typeable "x")+          pLabel3 = lx_ .*. ly_ .*. emptyProxy+          pLabel5 = lx .*. ly .*. emptyProxy -- Proxy :: Proxy ["x","y"]+      return $ conjoin+        [ gread (gshow h) === [(h, "")],+          gread (gshow v) === [(v, "")],+          gread (gshow r) === [(r, "")] ]++  it "Enum" $ do+    show [ mkVariant lx False (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool]) .. maxBound ]+      `shouldBe` "[V{x=False},V{x=True},V{y=False},V{y=True}]"++  it "minBound" $ do+    mkVariant lx False (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool])+      `shouldBe` minBound++++  it "projected" $ do+    property $ do+      (f :: Bool -> Bool -> Bool) <- arbitrary+      x :: Bool <- arbitrary+      y :: Bool <- arbitrary+      let r = lx .=. x .*. ly .=. y .*. lz .=. () .*. emptyRecord+          g1 [pun| (x y) |] = case f x y of z -> [pun| z |]+          g2 [pun| (y x) |] = case f x y of z -> [pun| z |]++          rExpect = lx .=. x .*. ly .=. y .*. lz .=. f x y .*. emptyRecord++      containX :: Bool <- arbitrary+      let+          v p | containX = mkVariant lx x p+            | otherwise = mkVariant ly y Proxy+++          v1 = v (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool, Tagged "z" Char])+          v2 = v (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool])++          v1not = v1 & sameLength . sameLabels . projected %~ hMapV Just . (`asLabelsOf` labelsOf v2)+++      return $ conjoin+        [ (r & sameLabels . projected %~ g1) `eq` rExpect+        , (r & sameLabels . projected %~ g2) `eq` rExpect+        , (v1 ^? projected) === Just v2+        , review projected v2 === v1+          ]+++  it "unboxed" $ do+    property $ do+      (x :: Bool) <- arbitrary+      (y :: Bool) <- arbitrary+      (z :: Bool) <- arbitrary+      let r = [pun| x y z |]+          ru = r ^. unboxed+      return $ conjoin+       [ ru .!. lx === x,+         ru .!. ly === y,+         ru .!. lz === z,+         hUpdateMany r ru === ru,+         hMapRU not ru ^. from unboxed . unlabeled . re listAsHList'+                === map not [x,y,z],+         r === ru ^. from unboxed ]++  it "unboxedS" $ do+    property $ do+      (x :: Bool) <- arbitrary+      (y :: Int) <- arbitrary+      (z :: Int) <- arbitrary+      let r = [pun| x y z |]+          ru = r ^. unboxedS+      return $ conjoin+        [ ru .!. lx === x,+          ru .!. ly === y,+          ru .!. lz === z,+          r === ru ^. from unboxedS ]++  it "sortForRecordUS" $ do+    property $ do+      a :: Bool <- arbitrary+      b :: (Bool,Bool) <- arbitrary+      c :: Bool <- arbitrary+      d :: (Bool,Bool) <- arbitrary+      let r = [pun| a b c d |]+          sr = sortForRecordUS r+          ssr = sortForRecordUS sr++      return $ conjoin+        [ sr `eq` ssr,+          sr .!. (Label :: Label "a") === a,+          sr .!. (Label :: Label "b") === b,+          sr .!. (Label :: Label "c") === c,+          sr .!. (Label :: Label "d") === d,+          hRearrange' sr === r+        ]+++  it "monoid0" $ do+    mempty `shouldBe` HNil+    mempty `shouldBe` emptyRecord+    mempty `shouldBe` emptyTIP+    mempty `shouldBe` mkVariant1 lx ()+    mempty `shouldBe` (mkVariant ly () (Proxy :: Proxy '[Tagged "x" [Int], Tagged "y" ()]))+++  it "identity: rearranged relabeled unlabeled" $ do+    let r = lx .=. True .*.+            ly .=. () .*. emptyRecord+    (r ^. rearranged) `shouldBe` r+    (r ^. relabeled) `shouldBe` r+    (r & unlabeled %~ id) `shouldBe` r++  it "rearranged" $ do+    let r = lx .=. True .*.+            ly .=. () .*. emptyRecord+    let r2 = ly .=. () .*.+            lx .=. True .*. emptyRecord+    (r ^. rearranged) `shouldBe` r2++  it "relabeled" $ do+    let r = lx .=. True .*.+            ly .=. () .*. emptyRecord+    let r2 = ly .=. True .*.+            lx .=. () .*. emptyRecord+    (r ^. relabeled) `shouldBe` r2++  it "hMaybied" $ property $ do+    mx :: Maybe Bool <- arbitrary+    my :: Maybe Bool <- arbitrary+    let r = lx .=. mx .*. ly .=. my .*. emptyRecord+        vT = Proxy :: Proxy [Tagged "x" Bool, Tagged "y" Bool]+        (val, v)  = case (mx,my) of+          (Just x, Nothing) -> (Just x, Just (mkVariant lx x vT))+          (Nothing, Just y) -> (Just y, Just (mkVariant ly y vT))+          _ -> (Nothing, Nothing)++    return $ conjoin [+      (r^?hMaybied <&> unvariant) `eq` val,+      isJust v ==> ( hMaybied' # fromJust v === r ) ]++  it "hMaybied 2" $ property $ do+    x :: BoolN "x"  <- arbitrary+    my :: Maybe (BoolN "y") <- arbitrary+    let v = ly .=. my .*. mkVariant1 lx x+        r = ly .=. my .*. lx .=. Just x .*. emptyRecord++    return $ (r ^? hMaybied) `eq` do+      guard $ isNothing my+      Just v++  it "hMaybied update" $ property $ do+    (f :: BoolN "x" -> BoolN "w",y :: BoolN "y") <- arbitrary+    let x  = lx .=. (Nothing :: Maybe (BoolN "x")) .*. ly .=. Just y .*. emptyRecord+        x' = lx .=. (Nothing :: Maybe (BoolN "w")) .*. ly .=. Just y .*. emptyRecord++    return $ (x & sameLength . hMaybied . hPrism lx %~ f) === x'++  it "hPrism" $ property $ do+    x :: Bool <- arbitrary+    my :: Maybe (Maybe ()) <- arbitrary+    let v  = ly .=. my .*. mkVariant1 lx x+        v' = ly .=. my .*. mkVariant1 lx (not x)++        tic = my .*. mkTIC1 x+        tic' = my .*. mkTIC1 (not x)++    return $ conjoin+      [ v' `eq` (v & hPrism lx %~ not),+        tic' `eq` (tic & hLens' Label %~ not),+        tic' `eq` (tic & ticPrism %~ not)+      ]++  it "hDeleteAtLabel" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    let r  = lx .=. vx .*. ly .=. vy .*. lz .=. vz .*. emptyRecord+        ry =               ly .=. vy .*. lz .=. vz .*. emptyRecord+        rx = lx .=. vx .*.               lz .=. vz .*. emptyRecord++    return $ conjoin [+      (r .-. lx) `eq` ry,+      (r .-. ly) `eq` rx ]++  it "hBuild/hEndR" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    let r = hEndR (hBuild vx vy vz) `asLabelsOf` (lx .*. ly .*. lz .*. emptyProxy)+        r_ = lx .=. vx .*. ly .=. vy .*. lz .=. vz .*. emptyRecord++    return $ r `eq` r_+++  it "hUncurry" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    return $ conjoin+      [ hUncurry (,,) (hBuild vx vy vz) `eq` (vx,vy,vz),+        hCurry (hUncurry (,,)) vx vy vz `eq` (vx,vy,vz),+#if __GLASGOW_HASKELL__ > 948+        hCurry (hUncurry id) vx `eq` vx,+#endif+        hCurry ( \(a `HCons` b `HCons` HNil) -> (b,a)) vx vy `eq` (vy,vx)+      ]++  it "hCompose" $ property $ do+    vx :: BoolN "x" <- arbitrary+    vy :: BoolN "y" <- arbitrary+    vz :: BoolN "z" <- arbitrary+    return $ conjoin+      [ hCompose (,) (,) vx vy vz `eq` ((vx,vy), vz)+        , hCompose id (,) vx vy `eq` (vx,vy),+#if __GLASGOW_HASKELL__ > 948+        , hCompose (,) id vx vy `eq` (vx,vy)+#endif+        ]+++hTuples = do+  it "HTuple0" $ do+    HNil ^. hTuple `shouldBe` ()+    (HNil & hTuple %~ id) `shouldBe` HNil++  it "HTuple2" $ property $ do+    a <- arbitrary+    b <- arbitrary+    let ab = (a :: BoolN "a",b :: BoolN "b")+    return $ hBuild a b ==  ab ^. from hTuple+        && hBuild a b ^. hTuple == ab++  it "HTuple3" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c")+    return $ hBuild a b c ==  abc ^. from hTuple+      && hBuild a b c ^. hTuple == abc++  it "HTuple4" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    d <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c",+               d :: BoolN "d")+    return $ hBuild a b c d ==  abc ^. from hTuple+      && hBuild a b c d ^. hTuple == abc++  it "HTuple5" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    d <- arbitrary+    e <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c",+               d :: BoolN "d", e :: BoolN "e")+    return $ hBuild a b c d e ==  abc ^. from hTuple+      && hBuild a b c d e ^. hTuple == abc++  it "HTuple6" $ property $ do+    a <- arbitrary+    b <- arbitrary+    c <- arbitrary+    d <- arbitrary+    e <- arbitrary+    f <- arbitrary+    let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c",+               d :: BoolN "d", e :: BoolN "e", f :: BoolN "f")+    return $ hBuild a b c d e f ==  abc ^. from hTuple+      && hBuild a b c d e f ^. hTuple == abc+++++-- XXX projected+v =  mkVariant (Label :: Label "x") () (Proxy :: Proxy '[Tagged "x" (), Tagged "y" Double])+vy = mkVariant (Label :: Label "y") 2.4 (Proxy :: Proxy '[Tagged "x" (), Tagged "y" Double])++vp1 :: Maybe (Variant '[Tagged "x" ()])+vp1 =  projectVariant v+++vp1_ = fromJust vp1+++vp2 = extendsVariant vp1_ `asTypeOf` v+vp3 = extendsVariant vp1_ `asLabelsOf` v++vp4 = (v ^? projected) `asTypeOf` vp1++vp5 = (projected # fromJust vp1) `asTypeOf` v+++vm1 = v & sameLength . sameLabels . projected %~ (\x -> x :: Variant '[Tagged "x" ()])++vm2 = v & sameLength . sameLabels . projected . sameLabels %~ f2+vm3 = vy & sameLength . sameLabels . projected . sameLabels %~ f2+++f2 (review hMaybied -> [pun| (x) |]) = hBuild (Just (show x)) ^?! hMaybied++f3 :: Show a => Variant '[Tagged "x" a] -> Variant '[Tagged "x" String]+f3 = unvarianted %~ show+++hm1 = Proxy :: HMemberM (Tagged "y" Double) '[Tagged "x" (), Tagged "y" Char] inY => Proxy inY++v2 = fmap (`asLabelsOf` (Proxy :: Proxy '[Label "y"])) (projectVariant v)+v_id = fmap (`asLabelsOf` v) (projectVariant v)+v_id2 = fmap (`asLabelsOf` labelsOf v) (projectVariant v)
+ examples/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/Main.hs view
@@ -0,0 +1,3 @@+-- just a stub for GHC+import qualified MainGhcGeneric1+main = MainGhcGeneric1.mainExport
+ examples/broken/MainGhcGeneric3.hs view
@@ -0,0 +1,24 @@++{-++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Included for completeness' sake.+   The TypeCastGeneric2.hs implementation is demonstrated.++-}++module MainGhcGeneric3 where++import Data.HList.FakePrelude hiding (TypeCast,typeCast)+import Data.HList.TypeCastGeneric2+++{-----------------------------------------------------------------------------}++main = print ( typeCast 1+             , typeCast True+             )+++{-----------------------------------------------------------------------------}
+ examples/broken/MainGhcGeneric3.ref view
@@ -0,0 +1,1 @@+(1,True)
+ examples/broken/MainGhcTTypeable.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE FlexibleContexts #-}++{-++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   This is a main module for exercising a model with generic cast+   and TTypeable-based type equality. This module is prepared for+   use with GHC. This model works, in principle, also for Hugs+   (see module HugsTTypeable), but some details and some test+   cases require slight variations.++-}+++import Datatypes1+import Data.HList.CommonMain+import Data.HList.GhcSyntax+import TypeEqBoolTTypeable+import TypeEqTTypeable+import Data.HList.TypeCastGeneric1+import Data.HList.Label1+++{-----------------------------------------------------------------------------}++type Animal =  HCons Key+              (HCons Name+              (HCons Breed+              (HCons Price+               HNil)))++angus :: Animal+angus =  HCons (Key 42)+           (HCons (Name "Angus")+           (HCons  Cow+           (HCons (Price 75.5)+            HNil)))++{-++HList> hFoldr (HSeq HShow) (return () :: IO ()) angus+Key 42+Name "Angus"+Cow+Price 75.5++HList> hAppend angus angus+HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) (HCons (Key+42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))))))++-}++testHArray = (myProj1,myProj2,myProj3,myProj4)+ where+  myProj1 = hProjectByHNats (HCons hZero (HCons hZero HNil)) angus+  myProj2 = hProjectByHNats (HCons hZero (HCons (hSucc hZero) HNil)) angus+  myProj3 = hProjectAwayByHNats (HCons hZero HNil) angus+  myProj4 = hSplitByHNats (HCons hZero (HCons (hSucc hZero) HNil)) angus++{-++*HArray> myProj1+HCons (Key 42) (HCons (Key 42) HNil)++*HArray> myProj2+HCons (Key 42) (HCons Cow HNil)++*HArray> myProj3+HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil))++*HArray> myProj4+(HCons (Key 42) (HCons (Name "Angus") HNil),HCons Cow (HCons (Price 75.5) HNil)++-}++testHOccurs = (testHOccurs1,testHOccurs2,testHOccurs3,testHOccurs4)+ where+  testHOccurs1 = hOccurs angus :: Breed+  testHOccurs2 = hOccurs (TIP (HCons 1 HNil))+  testHOccurs3 = null $ hOccurs (TIP (HCons [] HNil))+  testHOccurs4 = hProject angus :: (HCons Key (HCons Name HNil))++testTypeIndexed =   ( typeIdx1+                  , ( typeIdx2+                  , ( typeIdx3+                  , ( typeIdx4+                  , ( typeIdx5+                  , ( typeIdx6 ))))))+ where+  typeIdx1 = hDeleteMany (proxy::Proxy Name) angus+  typeIdx2 = hExtend BSE angus+  typeIdx3 = hUpdateAtType Sheep typeIdx1+  typeIdx4 = hDeleteAtProxy (proxy::Proxy Breed) typeIdx2+  typeIdx5 = hProjectByProxies (HCons (proxy::Proxy Breed) HNil) angus+  typeIdx6 = fst $ hSplitByProxies (HCons (proxy::Proxy Breed) HNil) angus++testTuple =   ( testTuple1+            , ( testTuple2+            , ( testTuple3+            , ( testTuple4+            , ( testTuple5+              )))))+ where+  testTuple1 = let (a,b) = tuple oneTrue in (a+(1::Int), not b)+  testTuple2 = let b = not $ fst $ tuple oneTrue in (1::Int,b)+  testTuple3 = tuple oneTrue == (1::Int,True)+  testTuple4 = ((+) (1::Int)) $ fst $ tuple oneTrue+  -- requires explicit type for tuple+  testTuple5 = ((+) (1::Int)) $ snd $ tuple oneTrue++testTIP = (testTIP1,testTIP2,testTIP3,testTIP4)+ where+  myTipyCow = TIP angus+  animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key+  animalKey = hOccurs+  testTIP1 = hOccurs myTipyCow :: Breed+  testTIP2 = hExtend BSE myTipyCow+  testTIP3 = hExtend Sheep $ tipyDelete (proxy::Proxy Breed) myTipyCow+  testTIP4 = tipyUpdate Sheep myTipyCow++testRecords =   ( test1 +              , ( test2+              , ( test3 +              , ( test4+              , ( test5+              , ( test6+                ))))))+ where+  key   = firstLabel+  name  = nextLabel key+  breed = nextLabel name+  price = nextLabel breed+  test1 = mkRecord $ HCons (newLVPair key (42::Integer))+                   $ HCons (newLVPair name "Angus")+                   $ HCons (newLVPair breed Cow)+                   $ HNil +  test2 = hLookupByLabel breed test1+  test3 = hDeleteAtLabel breed test1+  test4 = hUpdateAtLabel breed Sheep test1+  test5 = hExtend (newLVPair price 8.8) test1+  test6 = hProjectByLabels (HCons breed (HCons price HNil)) test5++++{-----------------------------------------------------------------------------}++main = print $   ( testHArray+               , ( testHOccurs+               , ( testTypeIndexed+               , ( testTuple+               , ( testTIP+               , ( testRecords+               ))))))+++{-----------------------------------------------------------------------------}+
+ examples/broken/MainGhcTTypeable.ref view
@@ -0,0 +1,1 @@+((HCons (Key 42) (HCons (Key 42) HNil),HCons (Key 42) (HCons (Name "Angus") HNil),HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)),(HCons (Key 42) (HCons (Name "Angus") HNil),HCons Cow (HCons (Price 75.5) HNil))),((Cow,1,True,HCons (Key 42) (HCons (Name "Angus") HNil)),((HCons (Key 42) (HCons Cow (HCons (Price 75.5) HNil)),(HCons BSE (HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))),(HCons (Key 42) (HCons Sheep (HCons (Price 75.5) HNil)),(HCons BSE (HCons (Key 42) (HCons (Name "Angus") (HCons (Price 75.5) HNil))),(HCons Cow HNil,HCons Cow HNil))))),(((2,False),((1,False),(True,(2,2)))),((Cow,TIP (HCons BSE (HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil))))),TIP (HCons Sheep (HCons (Key 42) (HCons (Name "Angus") (HCons (Price 75.5) HNil)))),TIP (HCons (Key 42) (HCons (Name "Angus") (HCons Sheep (HCons (Price 75.5) HNil))))),(Record{HZero=42,HSucc HZero="Angus",HSucc (HSucc HZero)=Cow},(Cow,(Record{HZero=42,HSucc HZero="Angus"},(Record{HZero=42,HSucc HZero="Angus",HSucc (HSucc HZero)=Sheep},(Record{HSucc (HSucc (HSucc HZero))=8.8,HZero=42,HSucc HZero="Angus",HSucc (HSucc HZero)=Cow},Record{HSucc (HSucc (HSucc HZero))=8.8,HSucc (HSucc HZero)=Cow}))))))))))
+ examples/broken/MainHugsTTypeable.hs view
@@ -0,0 +1,148 @@+{-++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   This is a main module for exercising a model with generic cast+   and TTypeable-based type equality. This module is prepared for use+   with Hugs. This model works in principle also for GHC (see module+   GHCTTypeable) perhaps modulo some slight differences in test cases.++-}+++import Datatypes1+import Data.HList.CommonMain+import TypeEqTTypeable+import TypeEqBoolTTypeable+import Data.HList.TypeCastGeneric1+import Data.HList.Label2+++{-----------------------------------------------------------------------------}++type Animal =  HCons Key+              (HCons Name+              (HCons Breed+              (HCons Price+               HNil)))++angus :: Animal+angus =  HCons (Key 42)+           (HCons (Name "Angus")+           (HCons  Cow+           (HCons (Price 75.5)+            HNil)))++{-++HList> hFoldr (HSeq HShow) (return () :: IO ()) angus+Key 42+Name "Angus"+Cow+Price 75.5++HList> hAppend angus angus+HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) (HCons (Key+42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))))))++-}++testHArray = (myProj1,myProj2,myProj3,myProj4)+ where+  myProj1 = hProjectByHNats (HCons hZero (HCons hZero HNil)) angus+  myProj2 = hProjectByHNats (HCons hZero (HCons (hSucc hZero) HNil)) angus+  myProj3 = hProjectAwayByHNats (HCons hZero HNil) angus+  myProj4 = hSplitByHNats (HCons hZero (HCons (hSucc hZero) HNil)) angus++{-++*HArray> myProj1+HCons (Key 42) (HCons (Key 42) HNil)++*HArray> myProj2+HCons (Key 42) (HCons Cow HNil)++*HArray> myProj3+HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil))++*HArray> myProj4+(HCons (Key 42) (HCons (Name "Angus") HNil),HCons Cow (HCons (Price 75.5) HNil)++-}++testHOccurs = (testHOccurs1,testHOccurs2,testHOccurs3,testHOccurs4)+ where+  testHOccurs1 = hOccurs angus :: Breed+  testHOccurs2 = hOccurs (TIP (HCons 1 HNil))+  testHOccurs3 = null $ hOccurs (TIP (HCons [] HNil))+  testHOccurs4 = hProject angus :: (HCons Key (HCons Name HNil))++testTypeIndexed =   ( typeIdx1+                  , ( typeIdx2+                  , ( typeIdx3+                  , ( typeIdx4+                  , ( typeIdx5+                  , ( typeIdx6 ))))))+ where+  typeIdx1 = hDeleteMany (proxy::Proxy Name) angus+  typeIdx2 = hExtend BSE angus+  typeIdx3 = hUpdateAtType Sheep typeIdx1+  typeIdx4 = hDeleteAtProxy (proxy::Proxy Breed) typeIdx2+  typeIdx5 = hProjectByProxies (HCons (proxy::Proxy Breed) HNil) angus+  typeIdx6 = fst $ hSplitByProxies (HCons (proxy::Proxy Breed) HNil) angus++-- Test for tuple omitted.+-- Too fragile.++myTipyCow = TIP angus+animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key+animalKey = hOccurs++testTIP = [show testTIP1, show testTIP2, show testTIP3, show testTIP4]+ where+  testTIP1 = hOccurs myTipyCow :: Breed+  testTIP2 = hExtend BSE myTipyCow+  testTIP3 = hExtend Sheep $ tipyDelete (proxy::Proxy Breed) myTipyCow+  testTIP4 = tipyUpdate Sheep myTipyCow++data MyNS = MyNS -- a name space for record labels+instance Show MyNS where show _ = "myNS"++testRecords =   ( test1 +              , ( test2+              , ( test3 +              , ( test4+              , ( test5+              , ( test6+                ))))))+ where+  key   = firstLabel MyNS  (undefined::DKey)+  name  = nextLabel  key   (undefined::DName)+  breed = nextLabel  name  (undefined::DBreed)+  price = nextLabel  breed (undefined::DPrice)+  test1 = mkRecord $ HCons (newF key (42::Integer))+                   $ HCons (newF name "Angus")+                   $ HCons (newF breed Cow)+                   $ HNil +  test2 = hLookupByLabel breed test1+  test3 = hDeleteAtLabel breed test1+  test4 = hUpdateAtLabel breed Sheep test1+  test5 = hExtend (newF price 8.8) test1+  test6 = hProjectByLabels (HCons breed (HCons price HNil)) test5++data DKey;   instance Show DKey   where show _ = "key"+data DName;  instance Show DName  where show _ = "name"+data DBreed; instance Show DBreed where show _ = "breed"+data DPrice; instance Show DPrice where show _ = "price"++{-----------------------------------------------------------------------------}++main = print $   ( testHArray+               , ( testHOccurs+               , ( testTypeIndexed+               , ( testTIP+               , ( testRecords+               )))))+++{-----------------------------------------------------------------------------}
+ examples/broken/MainHugsTTypeable.ref view
@@ -0,0 +1,1 @@+((HCons (Key 42) (HCons (Key 42) HNil),HCons (Key 42) (HCons (Name "Angus") HNil),HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)),(HCons (Key 42) (HCons (Name "Angus") HNil),HCons Cow (HCons (Price 75.5) HNil))),((Cow,1,True,HCons (Key 42) (HCons (Name "Angus") HNil)),((HCons (Key 42) (HCons Cow (HCons (Price 75.5) HNil)),(HCons BSE (HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))),(HCons (Key 42) (HCons Sheep (HCons (Price 75.5) HNil)),(HCons BSE (HCons (Key 42) (HCons (Name "Angus") (HCons (Price 75.5) HNil))),(HCons Cow HNil,HCons Cow HNil))))),(["Cow","TIP (HCons BSE (HCons (Key 42) (HCons (Name \"Angus\") (HCons Cow (HCons (Price 75.5) HNil)))))","TIP (HCons Sheep (HCons (Key 42) (HCons (Name \"Angus\") (HCons (Price 75.5) HNil))))","TIP (HCons (Key 42) (HCons (Name \"Angus\") (HCons Sheep (HCons (Price 75.5) HNil))))"],(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})))))))))
+ examples/broken/TTypeable.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,+  FlexibleContexts, UndecidableInstances #-}++{-+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Typeable at the type level.+-}++module TTypeable where++import Datatypes1+import Data.HList.FakePrelude+import Data.HList.HListPrelude+++class TTypeable a b | a-> b++type Zero     = HZero+type One      = HSucc Zero+type Two      = HSucc One+type Three    = HSucc Two+type Four     = HSucc Three+type Five     = HSucc Four+type Six      = HSucc Five+type Seven    = HSucc Six+type Eight    = HSucc Seven+type Nine     = HSucc Eight+type Ten      = HSucc Nine+type Eleven   = HSucc Ten+type Twelf    = HSucc Eleven+type Thirteen = HSucc Twelf+++-- Built-in datatypes+instance TTypeable Int     (HCons Zero  HNil)+instance TTypeable Integer (HCons One   HNil)+instance TTypeable Char    (HCons Two   HNil)+instance TTypeable Bool    (HCons Three HNil)+++-- Some type constructors+instance (TTypeable a al, TTypeable b bl)+      =>  TTypeable (a->b) (HCons Four (HCons al (HCons bl HNil)))+instance (TTypeable a al)+      =>  TTypeable [a] (HCons Five (HCons al HNil))+instance (TTypeable a al)+      =>  TTypeable (Maybe a) (HCons Six (HCons al HNil))+++-- Example of a higher-kind type++data Fix f = Fix (f (Fix f))++instance (TTypeable (f Bool) (HCons al l'))+      =>  TTypeable (Fix f) (HCons Seven (HCons al HNil))+++-- User-defined datatypes+instance TTypeable Float   (HCons Eight    HNil)+instance TTypeable Key     (HCons Nine     HNil)+instance TTypeable Name    (HCons Ten      HNil)+instance TTypeable Breed   (HCons Eleven   HNil)+instance TTypeable Price   (HCons Twelf    HNil)+instance TTypeable Disease (HCons Thirteen HNil)
+ examples/broken/TypeEqBoolTTypeable.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}+{-+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Implementations of type equality and disequality based on TTypeable.+   This approach works for GHC and Hugs.+-}++module TypeEqBoolTTypeable where++import Data.HList.FakePrelude+-- import Data.HList.TTypeable+-- import Data.HList.TypeEqTTypeable++instance TypeEq x y HTrue  => TypeEqTrue x y+instance TypeEq x y HFalse => TypeEqFalse x y
+ examples/broken/TypeEqExplosive.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS -fglasgow-exts #-}++{- ++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   This naive combinatorial approach to type equality is explosive.++-}+++module ExplosiveTypeEq where++import Data.HList.FakePrelude++instance TypeEqTrue Integer Integer+instance TypeEqTrue Char Char+instance (TypeEqTrue x x', TypeEqTrue y y') => TypeEqTrue (x->y) (x'->y')+ +instance TypeEqFalse Integer Char+instance TypeEqFalse Char Integer+instance TypeEqFalse (x->y) Integer+instance TypeEqFalse (Char->Integer) (Integer->Char)+instance TypeEqFalse (Char->Char) (Char->Integer) ++-- ... exploding ...
+ examples/broken/TypeEqTTypeable.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++{-+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   An implementation of a type equality predicate in terms+   of type-level type representations and their comparison.+   This approach works for GHC and Hugs.+-}++module TypeEqTTypeable where++import Data.HList.FakePrelude+import TTypeable+++-- Generic implementation of the type equality predicate+instance ( TTypeable t tt+         , TTypeable t' tt'+         , HEq tt tt' b+         )+      =>   TypeEq t t' b+++-- For conciseness+type Integer3 = Integer->Integer->Integer++testTTypeable :: [String]+testTTypeable+    = [+        show$ typeEq not (&&),+        show$ typeEq not not,++{-+    We got this:+     Context reduction stack overflow; size = 21+     Use -fcontext-stack20 to increase stack size to (e.g.) 20+    So we reduced the test suite a bit.++-}++--        show$ typeEq (&&) (||),+--        show$ typeEq ((+)::Integer3) ((-)::Integer3),+--        show$ typeEq ((*)::Integer3) ((*)::Integer3),+--        show$ typeEq ((*)::Integer3) not,+--        show$ typeEq True False,+        show$ typeEq (1::Integer) True,+        show$ typeEq False ((+)::Integer3),+        show$ typeEq (||) ((+)::Integer3),+        show$ typeEq (undefined::Fix Maybe) True,+        show$ typeEq (undefined::Fix Maybe) (undefined::Fix []),+        show$ typeEq (undefined::Fix Maybe) (undefined::Fix Maybe)+       ]
+ examples/broken/keyword-arguments.lhs view
@@ -0,0 +1,440 @@+From oleg-at-okmij.org Fri Aug 13 14:58:35 2004+To: haskell@haskell.org+Subject: Keyword arguments+From: oleg-at-pobox.com+Message-ID: <20040813215834.F1FF3AB7E@Adric.metnet.navy.mil>+Date: Fri, 13 Aug 2004 14:58:34 -0700 (PDT)+Status: OR+++We show the Haskell implementation of keyword arguments, which goes+well beyond records (e.g., in permitting the re-use of+labels). Keyword arguments indeed look just like regular, positional+arguments. However, keyword arguments may appear in any+order. Furthermore, one may associate defaults with some keywords; the+corresponding arguments may then be omitted. It is a type error to+omit a required keyword argument. The latter property is in stark+contrast with the conventional way of emulating keyword arguments via+records. Also in marked contrast with records, keyword labels may be+reused throughout the code with no restriction; the same label may be+associated with arguments of different types in different+functions. Labels of Haskell records may not be re-used.  Our solution+is essentially equivalent to keyword arguments of DSSSL Scheme or+labels of OCaml.++Keyword argument functions are naturally polyvariadic: Haskell does+support varargs! Keyword argument functions may be polymorphic. As+usual, functions with keyword arguments may be partially applied. On+the downside, sometimes one has to specify the type of the return+value of the function (if the keyword argument function has no+signature -- the latter is the norm, see below) -- provided that the+compiler cannot figure the return type out on its own. This is usually+only the case when we use keyword functions at the top level (GHCi+prompt).++Our solution requires no special extensions to Haskell and works with+the existing Haskell compilers; it is tested on GHC 6.0.1. The+overlapping instances extension is not necessary (albeit it is+convenient).++The gist of our implementation is the realization that the type of a+function is a polymorphic collection of its argument types -- a+collection that we can traverse. This message thus illustrates a+limited form of the reflection on a function.+++Our implementation is a trivial extension of the strongly-typed+polymorphic open records described in+	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+from the above site.++The HList paper discusses the issue of labels in some detail. The+paper gives three different representations. One of them needs no+overlapping instances and is very portable. In this message, we chose+a representation that relies on generic type equality and therefore+needs overlapping instances as implemented in GHC. Again, this is+merely an outcome of our non-deterministic choice. It should be+emphasized that other choices are possible, which do not depend on +overlapping instances at all. Please see the HList paper for details.++> {-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}+> {-# OPTIONS -fallow-overlapping-instances #-}+> +> module KW where+> +> import FakePrelude hiding (TypeEq,typeEq,proxyEq,TypeCast,typeCast)+> import TypeEqGeneric2+> import TypeCastGeneric2+> import HListPrelude+++We will be using an example inspired by a graphics toolkit -- the area+which really benefits from keyword arguments. We first define our+labels and useful datatypes++> data Color = Color+> data Size  = Size+> data Origin  = Origin+> data RaisedBorder = RaisedBorder+>+> data CommonColor = Red | Green | Blue deriving Show+> data RGBColor = RGBColor Int Int Int deriving Show++and two functions:++> make_square Size n Origin (x0,y0) Color (color::CommonColor) =+>   unwords ["Square:", show n, "at", show (x0,y0), show color] ++ "\n"+> +> make_rect Size (nx,ny) Origin (x0,y0) Color (color::RGBColor)+> 	 RaisedBorder border =+>   unwords ["Rectangle:", show (nx,ny), "at", show (x0,y0),+> 	   show color, if border then "raised border" else ""] ++ "\n"+++We are not interested in really drawing squares and rectangles+here. Therefore, make_square and make_rect return a String, which we+can regard as a ``command'' to be passed to a low-level graphics+library. The functions make_square and make_rect are genuine functions+and can be used as such. They are not keyword argument functions, yet,+but they set the stage. These functions can be considered an+`interface' for the keyword argument functions. We should note that+the functions are polymorphic: for example, `Size' can be any+showable. We must also emphasize the re-use of the labels: The Color+of a square is the value of the enumerated type CommonColor. OTH, the+color of the rectangle is given as an RGB triple. The sizes of the+square and of the rectangle are specified differently too, the same+label notwithstanding.++Once the user wrote the functions such as make_square and make_rect,+he can _automatically_ convert them to their keyword+alternatives. This transformation is done by a function 'kw'. The user+should pass the positional-argument function (`labeled' as above),+and an HList of default values for some of the labels. The latter may+be HNil if all keyword arguments are required.++The first example (no defaults)++> tests1 :: String = +>     kw make_square HNil Size (1::Int) Origin (0::Int,10::Int) Color Red +	+we can permute the arguments at wish++> tests2 :: String = +>     kw make_square HNil Color Red Size (1::Int) Origin (0::Int,10::Int)  +	+we can also assign a name to a keyword function, or partially apply it:++> tests3 = let f x = kw make_square HNil Color Red x+> 	   in "here: " ++ f Origin (0::Int,10::Int) Size (1::Int) +	+The dummy argument 'x' is merely to avoid the monomorphic+restriction. The following is a more interesting example, with the+defaults:++> tests4 = let defaults = Origin .*. (0::Int,10::Int) .*.+> 			  RaisedBorder .*. True .*.+> 			  HNil+> 	   in kw make_square defaults Size (1::Int) Color Red +++> 	      kw make_rect   defaults Color (RGBColor 0 10 255)+> 	                              Size (1.0::Float, 2.0::Float)++The argument RaisedBorder is not given, and so the default value is+used. Of course, we can override the default:++> tests5 = let defaults = Origin .*. (0::Int,10::Int) .*.+> 			  RaisedBorder .*. True .*.+> 			  HNil+> 	       sq x = kw make_square defaults Color x+> 	       re x = kw make_rect   defaults x+> 	   in sq Red Size (1::Int) +++> 	      re Color (RGBColor 0 10 255)+> 	         RaisedBorder False+> 	         Size (1.0::Float, 2.0::Float)++We have reshuffled a few arguments, just for fun. As you can see, the+function `kw make_rect defaults' is polyvariadic indeed.  We chose to+partially apply 'Color' to the function `kw make_square defaults' --+so that the function `sq' is positional in its first argument, and+keyword in the rest.++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::Int,10::Int) ++  Couldn't match `ErrReqdArgNotFound Size' against `[Char]'+      Expected type: ErrReqdArgNotFound Size+      Inferred type: [Char] ...++The error message seems reasonably clear. Likewise we get an error+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::Int,10::Int) Size (1::Int) +]	                   RaisedBorder False++  No instances for (Fail (ErrUnexpectedKW RaisedBorder),+		    KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char])+      arising from use of `f' at ...+    In the second argument of `(++)', namely+	`f Origin (0 :: Int, 10 :: Int) Size (1 :: Int) RaisedBorder False'+++The function 'kw' receives the appropriately labeled function (such+as make_square) and the HList with default values. The function 'kw'+is polymorphic; the overloading is resolved based on the type of the+user function *and* on the type of its continuation. The continuation+indicates if a keyword argument is forthcoming, or not. In the latter+case, 'kw' checks to see if the supplied defaults can provide the+values of the still missing arguments. We see therefore that a+function type is more than it may appear -- the type of a function is+truly a heterogeneous, type level collection! The function 'kw'+traverses that collection, thus performing a limited form of+reflection on Haskell functions.+ ++Implementation Outline++One of the key tools of the implementation is 'kwapply', which applies+a function to a polymorphic collection of that function's arguments.+The order of the arguments in the collection is irrelevant. The+contraption kwapply can handle polymorphic functions with arbitrary+number of labeled arguments.++For example, if we define++> f1 Size n = show n+> f2 Size n Color m = unwords ["size:", show n, "color:", show m]+> f3 Origin x Color m Size n = +>     unwords ["origin:", show x, "size:", show n, "color:",show m]++then we can run++> katest1  = kwapply f1 (Size .*. () .*. HNil)+> katest11 = kwapply f1 (Size .*. "Large" .*. HNil)+> +> katest2  = kwapply f2 (Size .*. (1::Int) .*. Color .*. Red .*. HNil)+> katest21 = kwapply f2 (Color .*. Red .*. Size .*. (1::Int) .*.  HNil)+> +> katest3  = kwapply f3 (Size .*. (1::Int) .*. Origin .*. (2.0::Float) .*. +> 		         Color .*. Red .*. HNil)++Another key contraption is ++> reflect_fk:: (ReflectFK fn kws) => fn -> Arg kws HNil+> reflect_fk _ = Arg HNil++that reflects on a user-supplied function. It converts the *type* of a+user function to a collection of keywords required by that+function. This and the previous contraptions may be used to define an+`extended' version of some user function that takes more arguments --+without the need to enumerate all arguments of the original+function. We thus infringe on the area of object and module systems.++The rest of the implementation is just to convert `kw fn defaults' +into the application of kwapply. ++++The rest of the implementation++We should note that all implementation is written in the+continuation-passing style (CPS) -- at the term level and especially+at the _typeclass level_. One of the reasons is to avoid relying on+overlapping instances: we compare types with a predicate `TypeEq x y+hbool', obtain the type-level boolean, and dispatch to two+non-overlapping instances of an auxiliary, continuation class. One+instance handles HTrue, and the other the HFalse alternative. Please+see the HList paper for more discussion of this technique.++The other, equally important reason for the thorough CPS of the+typeclasses is to control the order of evaluation of constraints and+their functional dependencies. The sole reason is to produce+informative error messages. The order of constraints is irrelevant+when all the constraints are satisfied. However, if the user omitted a+required keyword, many of the constraints below will fail. If a+'wrong' constraint fails first, we get a totally off-the-wall error+message that gives us no clue whatsoever about the problem. By tightly+constraining the order via CPS, we are able to force the typechecker+to give informative error messages.+++Preliminaries++> -- A bit of syntax sugar for HLists+> infixr 1 :*:+> infixr 1 .*.+> type e :*: l = HCons e l+> (.*.) =  HCons+++Errors++> data ErrReqdArgNotFound x+> data ErrUnexpectedKW x+> data Trace x++All our keywords must be registered++> class IsKeyFN   t flag | t-> flag+> instance IsKeyFN (Color->a->b)  HTrue+> instance IsKeyFN (Size->a->b)   HTrue+> instance IsKeyFN (Origin->a->b) HTrue+> instance IsKeyFN (RaisedBorder->a->b) HTrue+> instance TypeCast HFalse flag => IsKeyFN t flag++The implementation of KWApply++> class KWApply f arg_values r | f arg_values -> r where+>     kwapply:: f -> arg_values -> r+> +> instance KWApply r HNil r where+>     kwapply f _ = f+> +> instance (TypeEq kw kw' flag,+> 	  KWApply' flag (kw->a->f') (kw' :*: a' :*: tail) r)+>     => KWApply (kw->a->f') (kw' :*: a' :*: tail) r where+>     kwapply = kwapply' (undefined::flag)+> +> class KWApply' flag f arg_values r  | flag f arg_values -> r  where+>     kwapply':: flag -> f -> arg_values -> r+> +> instance  (TypeCast v' v, KWApply f' tail r)+>     => KWApply' HTrue (kw->v->f') (kw :*: v' :*: tail) r where+>     kwapply' _ f (HCons kw (HCons v' tail)) = +>                    kwapply (f kw (typeCast v')) tail+> +> -- Rotate the arg list ...+> instance  (HAppend tail (kw :*: v :*: HNil) l',+> 	   KWApply f l' r)+>     => KWApply' HFalse f (kw :*: v :*: tail) r where+>     kwapply' _ f (HCons kw (HCons v tail)) = +> 	kwapply f (hAppend tail (kw .*. v .*. HNil))++The datatype Arg below is to maintain the state of keyword+accumulation: which keywords we need, and which keyword and values we+have already got.+arg_types is the phantom HList of keywords that are yet to be satisfied.+arg_values is the HList (kw .*. kw_value .*. etc)+of already found keywords and their values.++> newtype Arg arg_types arg_values = Arg arg_values deriving Show++Reflection on a function:+Given a function, return the type list of its keywords++> class ReflectFK f kws | f -> kws+> instance (IsKeyFN f flag, ReflectFK' flag f kws) => ReflectFK f kws+> class ReflectFK' flag f kws | flag f -> kws+> instance ReflectFK rest kws => ReflectFK' HTrue (kw->a->rest) (HCons kw kws)+> instance ReflectFK' HFalse f HNil++-- :t reflect_fk (undefined::Size->Int->Color->CommonColor->String)+-- :t reflect_fk (undefined::Size->Int->()->Int)++The main class: collect and apply the keyword arguments++> class KW f arg_desc arg_def r where+>     kwdo :: f -> arg_desc -> arg_def -> r+> +> instance (IsKeyFN r rflag, -- Fail (Trace (arg_desc,r)),+> 	    KW' rflag f arg_desc arg_def r)+>     => KW f arg_desc arg_def r where+>     kwdo = kw' (undefined::rflag)+> +> class KW' rflag f arg_desc arg_def r where+>     kw' :: rflag -> f -> arg_desc -> arg_def -> r++If the continuation r does not promise any more keyword+arguments, apply the defaults++> instance KWMerge arg_needed arg_values arg_def f r+>     => KW' HFalse f (Arg arg_needed arg_values) arg_def r where+>     kw' _ f args_given arg_def = kwmerge args_given arg_def f++Otherwise, collect the supplied keyword and its value, and recurse for+more:++> instance KWAcc arg_desc kw a f arg_def r+>     => KW' HTrue f arg_desc arg_def (kw->a->r) where+>     kw' _ f arg_desc arg_def kw a = kwaccum arg_desc kw a f arg_def+++Add the needed arguments from arg_def to arg_values and continue+with kwapply.+That is, we try to satisfy the missing arguments from the defaults.+It will be a type error if some required arguments are missing++> class KWMerge arg_needed arg_values arg_def f r |+>               arg_needed arg_values arg_def f -> r  where+>     kwmerge:: Arg arg_needed arg_values -> arg_def -> f -> r+> +> instance KWApply f arg_values r +>     => KWMerge HNil arg_values arg_def f r where+>     kwmerge (Arg arg_values) _ f = kwapply f arg_values+> +> instance KWMerge' kw arg_def atail arg_values arg_def f r+>     => KWMerge (HCons 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+> +> class KWMerge' kw list atail arg_values arg_def f r | +>                kw list atail arg_values arg_def f -> r where+>     kwmerge':: kw -> list -> (Arg atail arg_values) -> arg_def -> f -> r+> +> instance Fail (ErrReqdArgNotFound kw)+>     => KWMerge' kw HNil atail arg_values arg_def f+>                 (ErrReqdArgNotFound kw) where+>     kwmerge' = undefined+> instance (TypeEq kw kw' flag,+> 	  KWMerge'' flag kw (kw' :*: etc) atail arg_values arg_def f r)+>     => KWMerge' kw (kw' :*: etc) atail arg_values arg_def f r where+>     kwmerge' = kwmerge'' (undefined::flag)+> +> class KWMerge'' flag kw list atail arg_values arg_def f r |+>                 flag kw list atail arg_values arg_def f -> r where+>     kwmerge'':: flag -> kw -> list -> (Arg atail arg_values) -> arg_def+> 		-> f -> r+> instance KWMerge atail (kw :*: v :*: arg_values) arg_def f r+>     => KWMerge'' HTrue 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)))+> instance KWMerge' kw tail atail arg_values arg_def f r+>     => KWMerge'' HFalse kw (kw' :*: v' :*: tail)+>                  atail arg_values arg_def f r where+>     kwmerge'' _ kw (HCons _ (HCons _ tail)) = kwmerge' kw tail++Add the real argument to the Arg structure, and continue++> class KWAcc arg_desc kw a f arg_def r where+>     kwaccum:: arg_desc -> kw -> a -> f -> arg_def -> r+> +> instance (HDelete kw arg_types arg_types',+> 	  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))++Delete e from l to yield l' The element e must occur in l++> class HDelete e l l' | e l -> l'+> instance Fail (ErrUnexpectedKW e) => HDelete e HNil HNil+> instance (TypeEq e e' flag, HDelete' flag e (HCons e' tail) l')+>     => HDelete e (HCons e' tail) l'+> class HDelete' flag e l l' | flag e l -> l'+> instance HDelete' HTrue e (HCons e tail) tail+> instance HDelete e tail tail'+>     => HDelete' HFalse e (HCons e' tail) (HCons e' tail')++Finally,++> kw f = kwdo f (reflect_fk f)++
+ examples/rundoctests.hs view
@@ -0,0 +1,47 @@+import Data.List+import System.Process+import System.Exit+import System.IO+import Data.Char+import System.Environment++import Cabal++-- | tests that all the >>> comments are followed by correct output. Easiest is to+--+-- > cabal test+--+-- or+--+-- > runghc examples/rundoctests.hs+--+-- or+--+-- > runghc examples/rundoctests.hs Data/HList/File1.hs Data/HList/File2.hs+--+-- you need Cabal >= 1.18 since that's around when cabal repl got added.+main = do+    as <- getArgs+    (ExitSuccess, o, _) <- cabal+        ["repl","--ghc-options","-v0 -w"]+        ":show packages\n:show language"+    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/HSort.hs"]+            _ -> as++    let args = "-i.": "-idist/build/autogen":+             "-optP-include":+             "-optPdist/build/autogen/cabal_macros.h" :+             "-Idist/build/autogen" : "-w":+             files ++ flags+    readProcess "doctest" args ""+