packages feed

HList 0.2.3 → 0.3.0

raw patch · 118 files changed

+9631/−2967 lines, 118 filesdep +cmdargsdep +directorydep +doctestdep ~base

Dependencies added: cmdargs, directory, doctest, filepath, ghc-prim, hspec, lens, mtl, process, syb

Dependency ranges changed: base

Files

+ ChangeLog view
@@ -0,0 +1,206 @@+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,12 +1,11 @@ {- | -   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.  -} @@ -17,11 +16,60 @@  , module Data.HList.HArray  , module Data.HList.HOccurs  , module Data.HList.HTypeIndexed+ , module Data.HList.Record+ , module Data.HList.HList+ , module Data.HList.TypeEqO  , module Data.HList.TIP  , module Data.HList.TIC  , module Data.HList.HZip- , module Data.HList.Record  , module Data.HList.Variant++ -- * "Data.HList.Keyword"+ -- | the \"public\" parts. More examples are in the module documentation.+ , Kw(..), recToKW, IsKeyFN, K,  ErrReqdArgNotFound,  ErrUnexpectedKW++ -- * Labels+ {- | there are really only two options for now, but there are+   a couple different styles for the first option here:++   GHC supports type-level strings ('GHC.TypeLits.Symbol'), and these can be+   labels. You can refer to these strings using an unwieldy syntax. For+   example if you want to store a value @5@ in a record @rec@ with a field+   called @\"x\"@, and then get it out again:++   let rec = ('Label' :: Label \"x\") '.=.' 5 '.*.' 'emptyRecord'++   rec '.!.' (Label :: Label \"x\")++   To avoid that pain, you can have a definition @x = Label :: Label "x"@.+   and just use @x@ instead of repeating @Label :: Label \"x\"@ so that+   a lookup becomes:++   > rec .!. x++   See 'makeLabels6' for automating the @x = Label :: Label \"x\"@.++ -}+ -- $label6demo++ , module Data.HList.Labelable+ -- $labelable++ -- ** namespaced labels+ , module Data.HList.Label3++ -- | template haskell for automating different types of labels+ , module Data.HList.MakeLabels+ -- | quasiquoter 'pun' helps to avoid needing a proxy value with+ -- type 'Label' in the first place: when you take values out of or into+ -- records with pattern matching, the variable name determines the label+ -- name.+ , module Data.HList.RecordPuns+++ -- * "Data.HList.Data"+ -- | This modules provide useful instances. A useful application can be+ -- found in @examples/cmdargs.hs@ ) where  import Data.HList.FakePrelude@@ -29,8 +77,67 @@ import Data.HList.HArray import Data.HList.HOccurs import Data.HList.HTypeIndexed+import Data.HList.Record+import Data.HList.HList+import Data.HList.MakeLabels+import Data.HList.TypeEqO import Data.HList.TIP import Data.HList.TIC+ import Data.HList.HZip-import Data.HList.Record+import Data.HList.Label3+import Data.HList.Label6 () -- only instances+import Data.HList.Labelable+ import Data.HList.Variant++import Data.HList.Data () -- only instances++import Data.HList.Keyword+import Data.HList.RecordPuns++{- $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 lenses for "Control.Lens".+Here is an example of how much better that is:++>>> :set -XNoMonomorphismRestriction -XDataKinds -XPolyKinds+>>> import Control.Lens+>>> let x = hLens' (Label :: Label "x")++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=()}++-}++
+ Data/HList/Data.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE CPP #-}++{- | 'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend+to be flat data structures. The @Data@ instance for 'HList' gives a nested+structure.++NOTE: these instances do not work with ghc-7.8 because of+<http://ghc.haskell.org/trac/ghc/ticket/8486>++[@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(..),+    ) where++import Data.HList.FakePrelude+import Data.HList.HList+import Data.HList.Record+import GHC.TypeLits+import Data.Data+import Data.List+import GHC.Exts (Constraint)++import Unsafe.Coerce+++instance (Data x, Data (HList xs), Typeable (HList (x ': xs)),+        TypeablePolyK (x ': xs))+        => Data (HList (x ': xs)) where+    gfoldl k z (HCons a b) = (z HCons `k` a) `k` b+    gunfold k z _ = k (k (z HCons))++    dataTypeOf _ = hListDataRep+    toConstr _   = hConsConRep+++instance (TypeablePolyK ('[] :: [*])) => Data (HList '[]) where+    gfoldl _k z HNil = z HNil+    gunfold _k z _ = z HNil+    dataTypeOf _ = hListDataRep+    toConstr _   = hNilConRep++hListDataRep = mkDataType "Data.HList.HList" [hConsConRep, hNilConRep]+hConsConRep = mkConstr hListDataRep "HCons" [] Prefix+hNilConRep = mkConstr hListDataRep "HNil" [] Prefix++-- | this data type only exists to have Data instance+newtype HListFlat a = HListFlat (HList a)++type DataHListFlatCxt g a = (HBuild' '[] g,+        Typeable (HListFlat a),+        TypeablePolyK a,+        HFoldl (GfoldlK  C) (C g) a (C (HList a)),++        HFoldr+            (GunfoldK C)+            (C g)+            (HReplicateR (HLength a) ())+            (C (HList a)),++        HReplicate (HLength a) ())++instance DataHListFlatCxt 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 (LVPair x t ': xs) where+    recordLabelsStr _ = showLabel (undefined :: 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 (undefined :: Label x) :+                            recordLabelsStr2 (undefined :: 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 MIN_VERSION_base(4,7,0)+deriving instance Typeable Record+deriving instance Typeable HList+deriving instance Typeable HListFlat+deriving instance Typeable LVPair++type TypeablePolyK (a :: k) = (Typeable a)+#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 ShowLabel sy => Typeable1 (LVPair sy) where+  typeOf1 _ = mkTyConApp+        (mkTyCon3 "HList" "Data.HList.Data" (showLabel (undefined :: Label sy)))+        []++instance (ShowLabel sy, Typeable x) => Typeable (LVPair sy x) where+  typeOf _ = mkTyConApp+            (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (undefined :: Label sy)))+            [mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "=") [],+                    typeOf (undefined :: x)+                    ]++type TypeablePolyK a = (() :: Constraint)+++instance Typeable (HList a) => Typeable (HListFlat a) where+    typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Data" "HListFlat")+            [typeOf (error "Typeable HListFlat" :: HList a)]+#endif++++-- pretty-prints sort of like a real list+tyConList xs = mkTyConApp open ( intersperse comma xs ++ [close] )+    where+    open = mkTyCon3 "GHC" "GHC.TypeLits" "["+    close = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" "]") []+    comma = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" ",") []+++class TypeRepsList a where+  typeRepsList :: a -> [TypeRep]+++instance (TypeRepsList (Prime xs), ConvHList xs) => TypeRepsList (Record xs) where+  typeRepsList (Record xs) = typeRepsList (prime xs)++instance (TypeRepsList xs, Typeable x) => TypeRepsList (HCons' x xs) where+  typeRepsList (~(x `HCons'` xs))+        = typeOf x : typeRepsList xs++instance TypeRepsList HNil' 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/FakePrelude.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}  {- |    The HList library@@ -8,146 +7,439 @@    Some very basic technology for faking dependent types in Haskell. -} -module Data.HList.FakePrelude where+module Data.HList.FakePrelude+    (module Data.HList.FakePrelude,+     module Data.HList.FakePrelude.Proxy) where +import GHC.Prim (Constraint)+import GHC.TypeLits+import Data.HList.FakePrelude.Proxy -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------+-- * A heterogeneous apply operator --- * Booleans+-- | simpler/weaker version where type information only propagates forward+-- with this one. 'app' defined below, is more complicated / verbose to define,+-- but it offers better type inference. Most uses have been converted to+-- 'app', so there is not much that can be done with 'Apply'.+class Apply f a where+  type ApplyR f a :: *+  apply :: f -> a -> ApplyR f a+  apply = undefined                     -- In case we use Apply for+                                        -- type-level computations only -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"+{- $note + Polymorphic functions are not first-class in haskell. One solution is to+ write an instance of 'ApplyAB' for a data type that takes the place of+ the original function. In other words, --- **  Conjunction+ > data Fn = Fn+ > instance ApplyAB Fn a b where applyAB Fn a = actual_fn a -class (HBool t, HBool t', HBool t'') => HAnd t t' t'' | t t' -> t''- where-  hAnd :: t -> t' -> t''+ Normally you would have been able to pass around the definition actual_fn. -instance HAnd HFalse HFalse HFalse- where-  hAnd _ _ = hFalse+ [@Type inference / Local functional dependencies@] -instance HAnd HTrue HFalse HFalse- where-  hAnd _ _ = hFalse+ Note that @class ApplyAB@ has three parameters and no functional dependencies.+ Instances should be written in the style: -instance HAnd HFalse HTrue HFalse- where-  hAnd _ _ = hFalse+ > instance (int ~ Int, double ~ Double) => ApplyAB Fn int double+ >  where applyAB _ = fromIntegral -instance HAnd HTrue HTrue HTrue+ 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@. Additional explanation can be found+ in <http://okmij.org/ftp/Haskell/typecast.html#local-fd local functional dependencies>++-}++-- | No constraints on result and argument types+class ApplyAB f a b where+  applyAB :: f -> a -> b+  applyAB = undefined -- In case we use Apply for type-level computations only+++{- $fun++ '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 plus1 = Fun (\x -> if x < 5 then x+1 else 5) :: Fun '[Num, Ord] '()+ >>> :t applyAB plus1+ applyAB plus1 :: (Num a, Ord a) => a -> a++ 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 a => a -> a+++ >>> 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 forall f g a b c. (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++-- --------------------------------------------------------------------------+-- * Proxy+--++-- $note see "Data.HList.Proxy"++-- | A special 'Proxy' for record labels, polykinded+data Label l = Label++labelToProxy :: Label l -> Proxy l+labelToProxy = undefined++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  = undefined+hFalse :: Proxy False; hFalse = undefined++instance Show (Proxy True)  where show _ = "HTrue"+instance Show (Proxy False) where show _ = "HFalse"+++-- **  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 = undefined++ -- ** 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 = undefined -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+-}+++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 = undefined+hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = undefined+hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = undefined -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+instance HNat2Integral HZero where+    hNat2Integral _ = 0 -instance HNat2Integral HZero- where-  hNat2Integral _ = 0+instance HNat2Integral n => HNat2Integral (HSucc n) where+    hNat2Integral n = hNat2Integral (hPred n) + 1 -instance HNat2Integral n => HNat2Integral (HSucc n)- where-  hNat2Integral n = hNat2Integral (hPred n) + 1+instance HNat2Integral n => Show (Proxy (n :: HNat)) where +    show n = "H" ++ show (hNat2Integral n :: Integer)  -{-----------------------------------------------------------------------------}+-- | 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' --- * Maybies -data HNothing  = HNothing  deriving Show-data HJust x   = HJust x   deriving Show+-- | 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' --- * Equality for types+hLt :: Proxy x -> Proxy y -> Proxy (HLt x y)+hLt = undefined -class HBool b => HEq x y b | x y -> b +-- --------------------------------------------------------------------------+-- * Maybies+-- $maybiesNote We cannot use lifted Maybe since the latter are not populated++data    HNothing  = HNothing  deriving Show+newtype HJust x   = HJust x   deriving Show+++-- --------------------------------------------------------------------------++-- * 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+ -- Equality instances for naturals -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+instance HEq HZero HZero     True+instance HEq HZero (HSucc n) False+instance HEq (HSucc n) HZero False+instance HEq  n n' b => HEq (HSucc n) (HSucc n') b -hEq :: HEq x y b => x -> y -> b+hEq :: HEq x y b => x -> y -> Proxy b hEq =  undefined  -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------  -- * Staged equality -- |@@ -155,38 +447,22 @@ --  * Establish type equality statically -- --  * Establish remaining value-level equality dynamically+--+-- removed: use typeable+{-  class HStagedEq x y  where   hStagedEq :: x -> y -> Bool---{-----------------------------------------------------------------------------}---- | Less than--class HBool b => HLt x y b | x y -> b----- Equality instances for naturals--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--hLt   :: HLt x y b => x -> y -> b-hLt _ =  undefined+-}  -{-----------------------------------------------------------------------------}+{-+-- --------------------------------------------------------------------------  -- | A predicate for type equality ----- There are different implementations.------ See imports in Main*.hs+-- There are different implementations: see TypeEq*.hs  class HBool b => TypeEq x y b | x y -> b @@ -200,58 +476,19 @@ proxyEq :: TypeEq t t' b => Proxy t -> Proxy t' -> b proxyEq _ _ = undefined --{-----------------------------------------------------------------------------}+-} --- * Type-safe cast+-- --------------------------------------------------------------------------+-- * Type-safe cast -- no longer need. We use a a ~ b +{- class TypeCast x y | x -> y, y -> x  where   typeCast :: x -> y---{-----------------------------------------------------------------------------}---- * A phantom type for type proxies--data Proxy e-instance Show (Proxy e) where show _ = "Proxy"--proxy :: Proxy e-proxy =  undefined--toProxy :: e -> Proxy e-toProxy _ = undefined--unProxy :: Proxy e -> e-unProxy =  undefined---{-----------------------------------------------------------------------------}---- * Type equality and disequality--class TypeEqTrue x y-class TypeEqFalse x y--typeEqTrue :: TypeEqTrue x y => x -> y -> ()-typeEqTrue _ _ = ()--typeEqFalse :: TypeEqFalse x y => x -> y -> ()-typeEqFalse _ _ = ()---{-----------------------------------------------------------------------------}---- * Subtyping--class SubType l l'--subType :: SubType l l' => l -> l' -> ()-subType _ _ = ()+-}  -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------  -- * Error messages @@ -259,4 +496,3 @@ class Fail x  -{-----------------------------------------------------------------------------}
+ Data/HList/FakePrelude/Proxy.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}++{- | Injection from algebraic kinds to *++Algebraic kinds like Nat are not populated and we can't use +values of type Nat as function arguments. In contrast, we can use+(undefined :: Proxy Z) as an argument, as a value proxy.+data Proxy (tp :: k) :: *++re-exports 'Data.Typeable.Proxy' if it exists+-}+module Data.HList.FakePrelude.Proxy (Proxy, proxy) where++#if MIN_VERSION_base(4,7,0)+import Data.Typeable (Proxy(..))+#else++data Proxy tp +#endif++proxy :: Proxy tp+proxy =  undefined+
− 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,195 @@ 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 HNat n => HUpdateAtHNat n e l l' | n e l -> l', l' n -> e- where-  hUpdateAtHNat :: n -> e -> l -> l'+class HUpdateAtHNat (n :: HNat) e (l :: [*]) where+  type HUpdateAtHNatR (n :: HNat) e (l :: [*]) :: [*]+  hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) -instance HUpdateAtHNat HZero e' (HCons e l) (HCons e' l)- where-  hUpdateAtHNat _ e' (HCons _ l) = HCons e' l+instance HUpdateAtHNat HZero e1 (e ': l) where+  type HUpdateAtHNatR  HZero e1 (e ': l) = e1 ': l+  hUpdateAtHNat _ e1 (HCons _ l)         = HCons e1 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 n e1 l => HUpdateAtHNat (HSucc n) e1 (e ': l) where+  type HUpdateAtHNatR  (HSucc n) e1 (e ': l) = e ': (HUpdateAtHNatR n e1 l)+  hUpdateAtHNat n e1 (HCons e l) = HCons e (hUpdateAtHNat (hPred n) e1 l)  -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------+-- * Projection --- * 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)+-- One way of implementing it: -class HNats ns => HSplitByHNats' ns l l' l'' | ns l -> l' l''- where-  hSplitByHNats' :: ns -> l -> (l',l'')+hProjectByHNats' ns l = hMap (FHLookupByHNat l) ns -instance HSplit l l' l''-      => HSplitByHNats' HNil l HNil l'- where-  hSplitByHNats' HNil l = (HNil,l')-   where-    (l',_) = hSplit l+newtype FHLookupByHNat (l :: [*]) = FHLookupByHNat (HList l) -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'''+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. -{-----------------------------------------------------------------------------}+-- 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. --- * Projection+hProjectByHNats (_ :: Proxy (ns :: [HNat])) l = +    hUnfold (FHUProj :: FHUProj True ns) (l,hZero) -class HNats ns => HProjectByHNats ns l l' | ns l -> l'- where-  hProjectByHNats :: ns -> l -> l'+data FHUProj (sel :: Bool) (ns :: [HNat]) = FHUProj -instance HProjectByHNats HNil HNil HNil- where-  hProjectByHNats _ _ = HNil+instance Apply (FHUProj sel ns) (HList '[],n) where+    type ApplyR (FHUProj sel ns) (HList '[],n) = HNothing+    apply _ _ = HNothing -instance HProjectByHNats HNil (HCons e l) HNil- where-  hProjectByHNats _ _ = HNil+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 (undefined::ch,fn) s -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 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) +       (ApplyR (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) (ApplyR (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 +213,4 @@ hSingle :: (HSingleton l, HHead l e) => l -> e hSingle = hHead --{-----------------------------------------------------------------------------}+-}
+ Data/HList/HList.hs view
@@ -0,0 +1,1023 @@+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Basic declarations for typeful heterogeneous lists.++   Excuse the unstructured haddocks: while there are many declarations here+   some are alternative implementations should be grouped, and the definitions+   here are analgous to many list functions in the "Prelude".+ -}++module Data.HList.HList where++import Data.HList.FakePrelude+import Data.HList.HListPrelude++import Control.Applicative (Applicative, liftA2, pure)+++-- --------------------------------------------------------------------------+-- * Heterogeneous type sequences+-- $note+--+-- The easiest way to ensure that sequences can only be formed with Nil+-- and Cons is to use GADTs+-- The kind [*] is list kind (lists lifted to types)++data HList (l::[*]) where+    HNil  :: HList '[]+    HCons :: e -> HList l -> HList (e ': l)++-- | this comparison is two traversals+instance (ConvHList l, Eq (Prime l)) => Eq (HList l) where+    x == y = prime x == prime y++-- ** Alternative representation+{- $note++HNil' and HCons' are the older ADT-style. This has some advantages+over the GADT:++* lazy pattern matches are allowed++* type inference is better if you want to directly pattern match+<http://stackoverflow.com/questions/19077037/is-there-any-deeper-type-theoretic-reason-ghc-cant-infer-this-type see stackoverflow post here>++-}+data HNil' = HNil' deriving (Eq)+data HCons' a b = HCons' a b deriving (Eq)+++-- | conversion between GADT ('HList') and ADT ('HNil'' 'HCons'')+-- representations+class (UnPrime (Prime a) ~ a) => ConvHList (a :: [*]) where+    type Prime a :: *+    type UnPrime b :: [*]+    prime :: HList a -> Prime a+    unPrime :: Prime a -> HList a++instance ConvHList as => ConvHList (a ': as) where+    type Prime   (a ': as) = a `HCons'` Prime as+    type UnPrime (b `HCons'` bs) = (b ': UnPrime bs)+    prime (a `HCons` as) = a `HCons'` prime as+    unPrime ~(a `HCons'` as) = a `HCons` unPrime as++instance ConvHList '[] where+    type Prime '[] = HNil'+    type UnPrime HNil' = '[]+    prime _ = HNil'+    unPrime _ = HNil+++++instance Show (HList '[]) where+    show _ = "H[]"++instance (Show e, Show (HList l)) => Show (HList (e ': l)) where+    show (HCons x l) = let 'H':'[':s = show l+		       in "H[" ++ show x ++ +			          (if s == "]" then s else ", " ++ s)++infixr 2 `HCons`+++-- --------------------------------------------------------------------------+-- * Basic list functions++-- | 'head'+hHead :: HList (e ': l) -> e+hHead (HCons x _) = x++-- | 'tail'+hTail :: HList (e ': l) -> HList l+hTail (HCons _ l) = l++-- | Length+type family HLength (x :: [*]) :: HNat+type instance HLength '[] = HZero+type instance HLength (x ': xs) = HSucc (HLength xs)++hLength   :: HList l -> Proxy (HLength l)+hLength _ =  undefined++-- ** Append+instance HExtend e (HList l) where+  type HExtendR e (HList l) = HList (e ': l)+  (.*.) = HCons++instance HAppend (HList l1) (HList l2) where+  type HAppendR (HList l1) (HList l2) = HList (HAppendList l1 l2)+  hAppend = hAppendList++type family HAppendList (l1 :: [*]) (l2 :: [*]) :: [*]+type instance HAppendList '[] l = l+type instance HAppendList (e ': l) l' = e ': HAppendList l l'++-- | the same as 'hAppend'+hAppendList :: HList l1 -> HList l2 -> HList (HAppendList l1 l2)+hAppendList HNil l = l+hAppendList (HCons x l) l' = HCons x (hAppend l l')++-- --------------------------------------------------------------------------++-- ** Alternative append+++-- | 'hAppend'' below is implemented using the same idea+append' :: [a] -> [a] -> [a]+append' l l' = foldr (:) l' l++-- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr'+hAppend' :: (HFoldr FHCons v l r) => HList l -> v -> r+hAppend' l l' = hFoldr FHCons l' l++data FHCons = FHCons++instance ( x ~ (e,HList l), y ~ (HList (e ': l))) => ApplyAB FHCons x y  where+    applyAB _ (e,l) = HCons e l+++-- ** Historical append++{- $++The original HList code is included below. In both cases+we had to program the algorithm twice, at the term and the type levels.++[@The class HAppend@]++> class HAppend l l' l'' | l l' -> l''+>  where+>   hAppend :: l -> l' -> l''+>++[@The instance following the normal append@]++> instance HList l => HAppend HNil l l+>  where+>   hAppend HNil l = l+>+> instance (HList l, HAppend l l' l'')+>       => HAppend (HCons x l) l' (HCons x l'')+>  where+>   hAppend (HCons x l) l' = HCons x (hAppend l l')++-}++-- --------------------------------------------------------------------------+-- * Reversing HLists++-- Append the reversed l1 to l2+type family HRevApp (l1 :: [*]) (l2 :: [*]) :: [*]+type instance HRevApp '[] l = l+type instance HRevApp (e ': l) l' = HRevApp l (e ': l')++hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)+hRevApp HNil l = l+hRevApp (HCons x l) l' = hRevApp l (HCons x l')++hReverse l = hRevApp l HNil++++-- --------------------------------------------------------------------------++--+-- * A nicer notation for lists+--+++-- | List termination+hEnd :: HList l -> HList l+hEnd = id++{- ^+   Note:++        [@x :: HList a@] means: @forall a. x :: HList a@++        [@hEnd x@] means: @exists a. x :: HList a@+-}+++-- |  Building lists++hBuild :: (HBuild' '[] r) => r+hBuild =  hBuild' HNil++class HBuild' l r where+    hBuild' :: HList l -> r++instance (l' ~ HRevApp l '[])+      => HBuild' l (HList l') where+  hBuild' l = hReverse l++instance HBuild' (a ': l) r+      => HBuild' l (a->r) where+  hBuild' l x = hBuild' (HCons x l)++-- ** examples+{- $examplesNote++The classes above allow the third (shortest) way to make a list+(containing a,b,c) in this case++> list = a `HCons` b `HCons` c `HCons` HNil+> list = a .*. b .*. c .*. HNil+> list = hEnd $ hBuild a b c++>>> let x = hBuild True in hEnd x+H[True]++>>> let x = hBuild True 'a' in hEnd x+H[True, 'a']++>>> let x = hBuild True 'a' "ok" in hEnd x+H[True, 'a', "ok"]++-}++-- *** historical+{- $hbuild the show instance has since changed, but these uses of+'hBuild'/'hEnd' still work++> HList> let x = hBuild True in hEnd x+> HCons True HNil++> HList> let x = hBuild True 'a' in hEnd x+> HCons True (HCons 'a' HNil)++> HList> let x = hBuild True 'a' "ok" in hEnd x+> HCons True (HCons 'a' (HCons "ok" HNil))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5))+> HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus+> True++-}++-- --------------------------------------------------------------------------++-- * folds+-- ** foldr+-- $foldNote  Consume a heterogenous list. GADTs and type-classes mix well+++class HFoldr f v (l :: [*]) r where+    hFoldr :: f -> v -> HList l -> r++instance (v ~ v') => HFoldr f v '[] v' where+    hFoldr       _ v _   = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr f v l r)+    => HFoldr f v (e ': l) r' where+    hFoldr f v (HCons x l)    = applyAB f (x, hFoldr f v l :: r)+++class HScanr f z ls rs where+    hScanr :: f -> z -> HList ls -> HList rs++instance HScanr f z '[] '[z] where+    hScanr _ z _ = HCons z HNil++instance (ApplyAB f (x,r) s, HScanr f z xs (r ': rs)) => HScanr f z (x ': xs) (s ': r ': rs) where+    hScanr f z (HCons x xs) =+        case hScanr f z xs :: HList (r ': rs) of+            HCons r rs -> (applyAB f (x,r) :: s) `HCons` r `HCons` rs++class HFoldr1 f (l :: [*]) r where+    hFoldr1 :: f -> HList l -> r++instance (v ~ v') => HFoldr1 f '[v] v' where+    hFoldr1      _ (HCons v _)  = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr1 f (e' ': l) r)+    => HFoldr1 f (e ': e' ': l) r' where+    hFoldr1 f (HCons x l)    = applyAB f (x, hFoldr1 f l :: r)+++-- ** foldl++{- | like 'foldl'+++>>> hFoldl (uncurry $ flip (:)) [] (1 `HCons` 2 `HCons` HNil)+[2,1]+++-}+class HFoldl f (z :: *) xs (r :: *) where+    hFoldl :: f -> z -> HList xs -> r++instance forall f z z' r x zx xs. (zx ~ (z,x), ApplyAB f zx z', HFoldl f z' xs r)+    => HFoldl f z (x ': xs) r where+    hFoldl f z (x `HCons` xs) = hFoldl f (applyAB f (z,x) :: z') xs++instance (z ~ z') => HFoldl f z '[] z' where+    hFoldl _ z _ = z++++++-- * unfold+-- $unfoldNote Produce a heterogenous list. Uses the more limited+-- 'Apply' instead of 'App' since that's all that is needed for uses of this+-- function downstream. Those could in principle be re-written.++hUnfold :: (Apply p s, HUnfold' p (ApplyR p s)) => p -> s -> HList (HUnfold p s)+hUnfold p s = hUnfold' p (apply p s)++type HUnfold p s = HUnfoldR p (ApplyR p s)++class HUnfold' p res where+    type HUnfoldR p res :: [*]+    hUnfold' :: p -> res -> HList (HUnfoldR p res)++instance HUnfold' p HNothing where+    type HUnfoldR p HNothing = '[]+    hUnfold' _ _ = HNil++instance (Apply p s, HUnfold' p (ApplyR p s)) => HUnfold' p (HJust (e,s)) where+    type HUnfoldR p (HJust (e,s)) = e ': HUnfold p s+    hUnfold' p (HJust (e,s)) = HCons e (hUnfold p s)+++-- * replicate++class HReplicate (n :: HNat) e where+    type HReplicateR n e :: [*]+    hReplicate :: Proxy n -> e -> HList (HReplicateR n e)++instance HReplicate HZero e where+    type HReplicateR HZero e = '[]+    hReplicate _ _ = HNil++instance HReplicate n e => HReplicate (HSucc n) e where+    type HReplicateR (HSucc n) e = e ': HReplicateR n e+    hReplicate n e = e `HCons` hReplicate (hPred n) e+++-- * concat++{- |++Like 'concat' but for HLists of HLists.++Works in ghci... puzzling as what is different in doctest (it isn't+@-XExtendedDefaultRules@)++> hConcat $ hBuild (hBuild 1 2 3) (hBuild 'a' "abc")++H[1, 2, 3, 'a', "abc"]+++-}+class HConcat (a :: [*]) where+    type HConcatR a :: [*]+    hConcat :: HList a -> HList (HConcatR a)++instance HConcat '[] where+    type HConcatR '[] = '[]+    hConcat _ = HNil++instance (x ~ HList t, HConcat xs) => HConcat (x ': xs) where+    type HConcatR (x ': xs) = HAppendList (UnHList x) (HConcatR xs)+    hConcat (x `HCons` xs) = x `hAppendList` hConcat xs+++type family UnHList a :: [*]+type instance UnHList (HList a) = a++-- --------------------------------------------------------------------------+-- * traversing HLists++-- ** producing HList+-- *** map+-- $mapNote It could be implemented with 'hFoldr', as we show further below++{- | hMap is written such that the length of the result list+can be determined from the length of the argument list (and+the other way around). Similarly, the type of the elements+of the list is propagated in both directions too.++Excuse the ugly types printed. Unfortunately ghc (still?)+shows types like @'[a,b]@ using the actual constructors involved+@(':) a ((':) b '[])@ (or even worse when the kind variables are printed).++>>> :set -XNoMonomorphismRestriction+>>> let xs = 1 .*. 'c' .*. HNil+>>> :t hMap (HJust ()) xs+hMap (HJust ()) xs+  :: Num y => HList ((':) * (HJust y) ((':) * (HJust Char) ('[] *)))+++These 4 examples show that the constraint on the length (2 in this cae)+can be applied before or after the 'hMap'. That inference is independent of the+direction that type information is propagated for the individual elements.+++>>> let asLen2 xs = xs `asTypeOf` (undefined :: HList '[a,b])++>>> let lr xs = asLen2 (applyAB (HMap HRead) xs)+>>> let ls xs = asLen2 (applyAB (HMap HShow) xs)+>>> let rl xs = applyAB (HMap HRead) (asLen2 xs)+>>> let sl xs = applyAB (HMap HShow) (asLen2 xs)+++>>> :t lr+lr+  :: (Read y, Read y1) =>+     HList ((':) * String ((':) * String ('[] *)))+     -> HList ((':) * y ((':) * y1 ('[] *)))++>>> :t rl+rl+  :: (Read y, Read y1) =>+     HList ((':) * String ((':) * String ('[] *)))+     -> HList ((':) * y ((':) * y1 ('[] *)))+++>>> :t ls+ls+  :: (Show y, Show y1) =>+     HList ((':) * y ((':) * y1 ('[] *)))+     -> HList ((':) * String ((':) * String ('[] *)))++>>> :t sl+sl+  :: (Show y, Show y1) =>+     HList ((':) * y ((':) * y1 ('[] *)))+     -> HList ((':) * String ((':) * String ('[] *)))++-}++hMap f xs = applyAB (HMap f) xs++newtype HMap f = HMap f++instance (HMapCxt f as bs as' bs') => ApplyAB (HMap f) as bs where+    applyAB (HMap f) = hMapAux f++type HMapCxt f as bs as' bs' = (HMapAux f as' bs', as ~ HList as', bs ~ HList bs',+    SameLength as' bs', SameLength bs' as')+++-- | 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 es2+instance (es2 ~ '[]) => SameLength '[] es2+instance (SameLength xs ys, es2 ~ (y ': ys)) => SameLength (x ': xs) es2+++++class HMapAux f (l :: [*]) (r :: [*]) where+  hMapAux :: (SameLength l r, SameLength r l) => f -> HList l -> HList r++instance HMapAux f '[] '[] where+  hMapAux       _  _  = HNil++instance (ApplyAB f e e', HMapAux f l l',+    SameLength l l', SameLength l' l)+    => HMapAux f (e ': l) (e' ': l') where+  hMapAux f (HCons x l)    = applyAB f x `HCons` hMapAux f l+++++-- --------------------------------------------------------------------------++-- **** alternative implementation+-- $note currently broken++newtype MapCar f = MapCar f++-- | Same as 'hMap' only a different implementation.+hMapMapCar :: (HFoldr (MapCar f) (HList '[]) l l') =>+    f -> HList l -> l'+hMapMapCar f = hFoldr (MapCar f) HNil++instance ApplyAB f e e' => ApplyAB (MapCar f) (e,HList l) (HList (e' ': l)) where+    applyAB (MapCar f) (e,l) = HCons (applyAB f e) l+++-- --------------------------------------------------------------------------++-- *** @appEndo . mconcat . map Endo@+{- |++>>> let xs = length .*. (+1) .*. (*2) .*. HNil+>>> hComposeList xs "abc"+8+++-}+hComposeList+  :: (HFoldr Comp (a -> a) l (t -> a)) => HList l -> t -> a+hComposeList fs v0 = let r = hFoldr (undefined :: Comp) (\x -> x `asTypeOf` r) fs v0 in r+++-- --------------------------------------------------------------------------++-- *** sequence+{- |+   A heterogeneous version of++   > sequenceA :: (Applicative m) => [m a] -> m [a]++   Only now we operate on heterogeneous lists, where different elements+   may have different types 'a'.+   In the argument list of monadic values (m a_i),+   although a_i may differ, the monad 'm' must be the same for all+   elements. That's why we needed "Data.HList.TypeCastGeneric2" (currently (~)).+   The typechecker will complain+   if we attempt to use hSequence on a HList of monadic values with different+   monads.++   The 'hSequence' problem was posed by Matthias Fischmann+   in his message on the Haskell-Cafe list on Oct 8, 2006++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018708.html>++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018784.html>+ -}++class (Applicative m, SameLength a b, SameLength b a) => HSequence m a b | a -> b, m b -> a where+    hSequence :: HList a -> m (HList b)+{- ^++[@Maybe@]++>>> hSequence $ Just (1 :: Integer) `HCons` (Just 'c') `HCons` HNil+Just H[1, 'c']++>>> hSequence $  return 1 `HCons` Just  'c' `HCons` HNil+Just H[1, 'c']+++[@List@]++>>> hSequence $ [1] `HCons` ['c'] `HCons` HNil+[H[1, 'c']]+++-}++instance Applicative m => HSequence m '[] '[] where+    hSequence _ = pure HNil++instance (m1 ~ m, Applicative m, HSequence m as bs) =>+    HSequence m (m1 a ': as) (a ': bs) where+    hSequence (HCons a b) = liftA2 HCons a (hSequence b)++-- data ConsM = ConsM+-- consM = LiftA2 FHCons+newtype LiftA2 f = LiftA2 f++instance (ApplyAB f (x,y) z, mz ~ m z, mxy ~ (m x, m y), Applicative m) => ApplyAB (LiftA2 f) mxy mz where+    applyAB (LiftA2 f) xy = liftA2 (curry (applyAB f)) `uncurry` xy++{-+instance (m1 ~ m, Applicative m) => ApplyAB ConsM (m a, m1 (HList l)) (m (HList (a ': l)))  where+{-+    type ApplyB ConsM (m a, m1 (HList l)) = Just (m (HList (a ': l)))+    type ApplyA ConsM (m (HList (a ': l))) = Just (m a, m (HList l))+    -}+    applyAB _ (me,ml) = liftA2 HCons me ml+    -}+++-- **** alternative implementation++-- | 'hSequence2' is not recommended over 'hSequence' since it possibly doesn't+-- allow inferring argument types from the result types. Otherwise this version+-- should do exactly the same thing.+--+-- The DataKinds version needs a little help to find the type of the+-- return HNil, unlike the original version, which worked just fine as+--+--  > hSequence l = hFoldr ConsM (return HNil) l+++{-+hSequence2 :: HSequence2 l f a => HList l -> f a+hSequence2 l =+    let rHNil = pure HNil `asTypeOf` (liftA undefined x)+        x = hFoldr ConsM rHNil l+    in x+++-- | abbreviation for the constraint on 'hSequence2'+type HSequence2 l f a = (Applicative f, HFoldr ConsM (f (HList ('[]))) l (f a))+-}+++-- --------------------------------------------------------------------------+++-- --------------------------------------------------------------------------+-- ** producing homogenous lists++-- *** map (no sequencing)+-- $mapOut This one we implement via hFoldr++newtype Mapcar f = Mapcar f++instance (l ~ [e'], ApplyAB f e e', el ~ (e,l)) => ApplyAB (Mapcar f) el l where+    applyAB (Mapcar f) (e, l) = applyAB f e : l++-- A synonym for the complex constraint+type HMapOut f l e = (HFoldr (Mapcar f) [e] l [e])++hMapOut :: forall f e l. HMapOut f l e => f -> HList l -> [e]+hMapOut f l = hFoldr (Mapcar f) ([] :: [e]) l+++-- --------------------------------------------------------------------------+-- *** mapM++-- |+--+-- > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b]+--+-- Likewise for mapM_.+--+-- See 'hSequence' if the result list should also be heterogenous.++hMapM   :: (Monad m, HMapOut f l (m e)) => f -> HList l -> [m e]+hMapM f =  hMapOut f++-- | GHC doesn't like its own type.+-- hMapM_  :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m ()+-- Without explicit type signature, it's Ok. Sigh.+-- Anyway, Hugs does insist on a better type. So we restrict as follows:+--+hMapM_   :: (Monad m, HMapOut f l (m ())) => f -> HList l -> m ()+hMapM_ f =  sequence_ .  disambiguate . hMapM f+ where+  disambiguate :: [q ()] -> [q ()]+  disambiguate =  id++++++-- --------------------------------------------------------------------------+-- * Type-level equality for lists ('HEq')++instance HEq '[] '[]      True+instance HEq '[] (e ': l) False+instance HEq (e ': l) '[] False+instance (HEq e1 e2 b1, HEq l1 l2 b2, br ~ HAnd b1 b2)+      => HEq (e1 ': l1) (e2 ': l2) br++-- --------------------------------------------------------------------------+-- * Ensure a list to contain HNats only+-- | We do so constructively, converting the HList whose elements+-- are Proxy HNat to [HNat]. The latter kind is unpopulated and+-- is present only at the type level.++type family HNats (l :: [*]) :: [HNat]+type instance HNats '[] = '[]+type instance HNats (Proxy n ': l) = n ': HNats l++hNats :: HList l -> Proxy (HNats l)+hNats = undefined+++-- --------------------------------------------------------------------------+-- * Membership tests++-- | Check to see if an HList contains an element with a given type+-- This is a type-level only test++class HMember (e1 :: k) (l :: [k]) (b :: Bool) | e1 l -> b+instance HMember e1 '[] False+instance (HEq e1 e b, HMember' b e1 l br) => HMember  e1 (e ': l) br+class HMember' (b0 :: Bool) (e1 :: k) (l :: [k]) (b :: Bool) | b0 e1 l -> b+instance HMember' True e1 l True+instance (HMember e1 l br) => HMember' False e1 l br++-- The following is a similar type-only membership test+-- It uses the user-supplied curried type equality predicate pred+type family HMemberP pred e1 (l :: [*]) :: Bool+type instance HMemberP pred e1 '[] = False+--type instance HMemberP pred e1 (e ': l) = HMemberP' pred e1 l (ApplyR pred (e1,e))++type family HMemberP' pred e1 (l :: [*]) pb :: Bool+type instance HMemberP' pred e1 l (Proxy True) = True+type instance HMemberP' pred e1 l (Proxy False) = HMemberP pred e1 l+ ++hMember :: HMember e l b => Proxy e -> Proxy l -> Proxy b+hMember = undefined++-- ** Another type-level membership test+--+-- | Check to see if an element e occurs in a list l+-- If not, return 'Nothing+-- If the element does occur, return 'Just l1+-- where l1 is a type-level list without e+class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r+instance HMemberM e1 '[] 'Nothing+instance (HEq e1 e b, HMemberM1 b e1 (e ': l) res)+      =>  HMemberM e1 (e ': l) res++class HMemberM1 (b::Bool) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM1 True e1 (e ': l) ('Just l)+instance (HMemberM e1 l r, HMemberM2 r e1 (e ': l) res)+    => HMemberM1 False e1 (e ': l) res++class HMemberM2 (b::Maybe [k]) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM2 Nothing e1 l Nothing+instance HMemberM2 (Just l1) e1 (e ': l) (Just (e ': l1))++-- --------------------------------------------------------------------------++-- * Staged equality for lists+-- $note removed. use Typeable instead++{-+instance HStagedEq (HList '[]) (HList '[])+ where+  hStagedEq _ _ = True++instance HStagedEq (HList '[]) (HList (e ': l))+ where+  hStagedEq _ _ = False++instance HStagedEq (HList (e ': l)) (HList '[])+ where+  hStagedEq _ _ = False++instance ( HEq e e' b+         , HStagedEq (HList l) (HList l')+         , HStagedEq' b e e'+         )+      =>   HStagedEq (HList (e ': l)) (HList (e' ': l'))+ where+  hStagedEq (HCons e l) (HCons e' l') = (hStagedEq' b e e') && b'+   where+    b  = proxy :: Proxy b+    b' = hStagedEq l l'++class HStagedEq' (b :: Bool) e e'+ where+  hStagedEq' :: Proxy b -> e -> e' -> Bool++instance HStagedEq' False e e'+ where+  hStagedEq' _ _ _ = False++instance Eq e => HStagedEq' True e e+ where+  hStagedEq' _ = (==)+-}++{-++++-- * Static set property based on HEq+class HSet l+instance HSet HNil+instance (HMember e l HFalse, HSet l) => HSet (HCons e l)+-}++-- * Find an element in a set based on HEq+-- | It is a pure type-level operation+class HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n++instance (HEq e1 e2 b, HFind' b e1 l n) => HFind e1 (e2 ': l) n++class HFind' (b::Bool) (e :: k) (l::[k]) (n::HNat) | b e l -> n+instance HFind' True e l HZero+instance HFind e l n => HFind' False e l (HSucc n)++++-- ** Membership test based on type equality++-- | could be an associated type if HEq had one+class HTMember e (l :: [*]) (b :: Bool) | e l -> b+instance HTMember e '[] False+instance (HEq e e' b, HTMember e l b', HOr b b' ~ b'')+      =>  HTMember e (e' ': l) b''++hTMember :: HTMember e l b => e -> HList l -> Proxy b+hTMember _ _ = proxy+++-- * Intersection based on HTMember++class HTIntersect l1 l2 l3 | l1 l2 -> l3+ where+  -- | Like 'Data.List.intersect'+  hTIntersect :: HList l1 -> HList l2 -> HList l3++instance HTIntersect '[] l '[]+ where+  hTIntersect _ _ = HNil++instance ( HTMember h l1 b+         , HTIntersectBool b h t l1 l2+         )+         => HTIntersect (h ': t) l1 l2+ where+  hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1+   where+    b = hTMember h l1++class HTIntersectBool (b :: Bool) h t l1 l2 | b h t l1 -> l2+ where+ hTIntersectBool :: Proxy b -> h -> HList t -> HList l1 -> HList l2++instance HTIntersect t l1 l2+      => HTIntersectBool True h t l1 (h ': l2)+ where+  hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1)++instance HTIntersect t l1 l2+      => HTIntersectBool False h t l1 l2+ where+  hTIntersectBool _ _ t l1 = hTIntersect t l1+++-- * Turn a heterogeneous list into a homogeneous one++-- | Same as @hMapOut Id@+class HList2List l e+ where+  hList2List :: HList l -> [e]++instance HList2List '[] e+ where+  hList2List HNil = []++instance HList2List l e+      => HList2List (e ': l) e+ where+  hList2List (HCons e l) = e:hList2List l+++++-- --------------------------------------------------------------------------+-- * With 'HMaybe'++-- ** Turn list in a list of justs+-- | the same as @map Just@+--+-- >>> toHJust (2 .*. 'a' .*. HNil)+-- H[HJust 2, HJust 'a']+--+-- >>> toHJust2 (2 .*. 'a' .*. HNil)+-- H[HJust 2, HJust 'a']++class ToHJust l l' | l -> l', l' -> l+ where+  toHJust :: HList l -> HList l'++instance ToHJust '[] '[]+ where+  toHJust HNil = HNil++instance ToHJust l l' => ToHJust (e ': l) (HJust e ': l')+ where+  toHJust (HCons e l) = HCons (HJust e) (toHJust l)++-- | alternative implementation. The Apply instance is in "Data.HList.FakePrelude".+-- A longer type could be inferred.+-- toHJust2 :: (HMap' (HJust ()) a b) => HList a -> HList b+toHJust2 xs = hMap (HJust ()) xs++-- --------------------------------------------------------------------------+-- ** Extract justs from list of maybes+--+-- >>> let xs = 2 .*. 'a' .*. HNil+-- >>> fromHJust (toHJust xs) == xs+-- True++class FromHJust l+ where+  type FromHJustR l :: [*]+  fromHJust :: HList l -> HList (FromHJustR l)++instance FromHJust '[]+ where+  type FromHJustR '[] = '[]+  fromHJust HNil = HNil++instance FromHJust l => FromHJust (HNothing ': l)+ where+  type FromHJustR (HNothing ': l) = FromHJustR l+  fromHJust (HCons _ l) = fromHJust l++instance FromHJust l => FromHJust (HJust e ': l)+ where+  type FromHJustR (HJust e ': l) = e ': FromHJustR l+  fromHJust (HCons (HJust e) l) = HCons e (fromHJust l)++-- *** alternative implementation++-- | A longer type could be inferred.+-- fromHJust2 :: (HMap' HFromJust a b) => HList a -> HList b+fromHJust2 xs = hMap HFromJust xs++data HFromJust = HFromJust+instance (hJustA ~ HJust a) => ApplyAB HFromJust hJustA a where+    applyAB _ (HJust a) = a+++-- --------------------------------------------------------------------------+-- * Annotated lists++data HAddTag t = HAddTag t+data HRmTag    = HRmTag++-- hAddTag :: HMap' (HAddTag t) l r => t -> HList l -> HList r+hAddTag t l = hMap (HAddTag t) l++-- hRmTag ::  HMap HRmTag l => HList l -> HList (HMapR HRmTag l)+hRmTag l    = hMap HRmTag l++instance (et ~ (e,t)) => ApplyAB (HAddTag t) e et+ where+  applyAB (HAddTag t) e = (e,t)+++instance (e' ~ e) => ApplyAB HRmTag (e,t) e'+ where+  applyAB _ (e,_) = e+++-- | Annotate list with a type-level Boolean+-- hFlag :: HMap' (HAddTag (Proxy True)) l r => HList l -> HList r+hFlag l = hAddTag hTrue l+++-- --------------------------------------------------------------------------+-- * Splitting by HTrue and HFalse++-- | Analogus to Data.List.'Data.List.partition' 'snd'+--+-- >>> hSplit $ (2,hTrue) .*. (3,hTrue) .*. (1,hFalse) .*. HNil+-- (H[2, 3],H[1])+--+-- it might make more sense to instead have @LVPair Bool e@+-- instead of @(e, Proxy Bool)@ since the former has the same+-- runtime representation as @e@++class HSplit l+ where+  type HSplitT l :: [*]+  type HSplitF l :: [*]+  hSplit :: HList l -> (HList (HSplitT l), HList (HSplitF l))++instance HSplit '[]+ where+  type HSplitT '[] = '[]+  type HSplitF '[] = '[]+  hSplit HNil = (HNil,HNil)++instance HSplit l => HSplit ((e, Proxy True) ': l)+ where++  type HSplitT ((e,Proxy True) ': l) = e ': HSplitT l+  type HSplitF ((e,Proxy True) ': l) = HSplitF l++  hSplit (HCons (e,_) l) = (HCons e l',l'')+   where+    (l',l'') = hSplit l++instance HSplit l => HSplit ((e,Proxy False) ': l)+ where+  type HSplitT ((e,Proxy False) ': l) = HSplitT l+  type HSplitF ((e,Proxy False) ': l) = e ': HSplitF l++  hSplit (HCons (e,_) l) = (l',HCons e l'')+   where+    (l',l'') = hSplit l++{-++Let expansion makes a difference to Hugs:++HListPrelude> let x = (hFlag (HCons "1" HNil)) in hSplit x+(HCons "1" HNil,HNil)+HListPrelude> hSplit (hFlag (HCons "1" HNil))+ERROR - Unresolved overloading+*** Type       : HSplit (HCons ([Char],HTrue) HNil) a b => (a,b)+*** Expression : hSplit (hFlag (HCons "1" HNil))+++-}
Data/HList/HListPrelude.hs view
@@ -1,687 +1,59 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  UndecidableInstances, FlexibleContexts #-}  {- |    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--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)---{-----------------------------------------------------------------------------}------- * A nicer notation for lists------- | List termination-hEnd :: HCons t t1 -> HCons t t1-hEnd t@(HCons _ _) = t--{- ^-   Note:--        [@x :: HCons a b@] means: @forall a b. x :: HCons a b@--        [@hEnd x@] means: @exists a b. x :: HCons a b@--}----- **  Building non-empty lists--hBuild   :: (HBuild' HNil a r) => a -> r-hBuild x =  hBuild' HNil x--class HBuild' l a r | r-> a l- where-  hBuild' :: l -> a -> r--instance HReverse (HCons a l) (HCons a' l')-      => HBuild' l a (HCons a' l')- where-  hBuild' l x = hReverse (HCons x l)--instance HBuild' (HCons a l) b r-      => HBuild' l a (b->r)- where-  hBuild' l x y = hBuild' (HCons x l) y--{- $hbuild--> 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---}--{-----------------------------------------------------------------------------}---- * 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)--instance Apply HRmTag (e,t) e- where-  apply HRmTag (e,_) = e----- | Annotate list with a type-level Boolean-hFlag :: (HMap (HAddTag HTrue) l l') => l -> l'-hFlag l = hAddTag hTrue l---{-----------------------------------------------------------------------------}---- * Splitting by HTrue and HFalse+class HExtend e l where+  type HExtendR e l+  (.*.) :: e -> l -> HExtendR e l+infixr 2 .*. --- | Analogus to @Data.List.partition snd@+-- Poly-kinded+class SubType l l' -class HSplit l l' l'' | l -> l' l''- where-  hSplit :: l -> (l',l'')+-- subType :: SubType l l' => l -> l' -> ()+-- subType _ _ = () -instance HSplit HNil HNil HNil- where-  hSplit HNil = (HNil,HNil)+-- poly-kinded+class HAppend l1 l2 where+  type HAppendR l1 l2+  hAppend :: l1 -> l2 -> HAppendR l1 l2 -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+-- class HMember e1 l (b :: Bool) | e1 l -> b -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+-- One occurrence and nothing is left+class HOccurs e l where+  hOccurs :: l -> e -{-+-- Class to test that a type is "free" in a type sequence+-- polykinded+class HOccursNot e l -Let expansion makes a difference to Hugs:+class HProject l l' where+  hProject :: l -> l' -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))+-- | Map a type (key) to a natural (index) within the collection+-- This is a purely type-level computation+class HType2HNat e l (n :: HNat) | e l -> n +--  | and lift to the list of types+class HTypes2HNats es l (ns :: [HNat]) | es l -> ns --}+-- | 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) +class HDeleteMany e l l' | e l -> l' where+  hDeleteMany :: Proxy e -> l -> l' -{-----------------------------------------------------------------------------}
Data/HList/HOccurs.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances,-  FlexibleContexts, OverlappingInstances, UndecidableInstances #-}  {- |    The HList library@@ -15,188 +13,128 @@  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 :: 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' (undefined::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 -> 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 (undefined::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 (undefined::e) l of+		   (HCons e l') -> (e,hOccursMany (l'::HList l')) +-- --------------------------------------------------------------------------+-- The first occurrence -{-----------------------------------------------------------------------------}+hOccursFst :: forall e l l'. HOccurrence e l (e ': l') => HList l -> e+hOccursFst l = case hOccurrence (undefined::e) l of HCons e _ -> e +-- -------------------------------------------------------------------------- -- 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 ( 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')+instance (HOccurrence e (x ': y) l', HOccurs' e l')+    => HOccurs e (HList (x ': y)) where+    hOccurs = hOccurs' . hOccurrence (undefined::e) -class HOccursBool b e l- where-  hOccursBool :: b -> l -> e+class HOccurs' e l where+    hOccurs' :: HList l -> e -instance ( HList l-         , HOccursNot e l-         )-           => HOccursBool HTrue e (HCons e l)- where-  hOccursBool _ (HCons e _) = e+instance Fail (TypeNotFound e) => HOccurs' e '[] where+    hOccurs' = undefined -instance ( HOccurs' e l-         , HList l-         )-           => HOccursBool HFalse e (HCons e' l)- where-  hOccursBool _ (HCons _ l) = hOccurs' l+instance (e ~ e1, HOccursNot e l) => HOccurs' e (e ': l) where+    hOccurs' (HCons e _) = e  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- 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 (undefined::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 HOccursNot e ('[]::[*])+instance (HEq e e1 b, HOccursNot' b e l) => HOccursNot e (e1 ': l)+class HOccursNot' (b :: Bool) e (l :: [*])+instance Fail (TypeFound e) => HOccursNot' True e l+instance HOccursNot e l => HOccursNot' False e l  -{-----------------------------------------------------------------------------}--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 +160,3 @@ > 1  -}--{-----------------------------------------------------------------------------}
Data/HList/HTypeIndexed.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  UndecidableInstances, FlexibleContexts #-}  {- |    The HList library@@ -13,112 +11,79 @@  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 :: HType2HNat e l n => Proxy e -> l -> Proxy n hType2HNat _ _ = undefined ----- | Map types to naturals--class HTypes2HNats ps l ns | ps l -> ns- where-  hTypes2HNats :: ps -> l -> ns+-- | And lift to the list of types -instance HTypes2HNats HNil l HNil- where-  hTypes2HNats _ _ = HNil+instance HTypes2HNats ('[] :: [*]) (l :: [*]) '[] -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 (HType2HNat e l n, HTypes2HNats es l ns)+      => HTypes2HNats (e ': es) (l :: [*]) (n ': ns) +hTypes2HNats :: HTypes2HNats es l ns => +		Proxy (es :: [*]) -> HList l -> Proxy (ns :: [HNat])+hTypes2HNats = undefined -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------+-- Implementing the generic interfaces --- | 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 '[]) (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 (undefined:: 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 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 e (HList l) (HList l1) => HDeleteManyCase True e e l l1+ where+  hDeleteManyCase _ p _ l = hDeleteMany p l  -{-----------------------------------------------------------------------------}---- | Projection based on proxies-hProjectByProxies :: (HProjectByHNats ns l l', HTypes2HNats ps l ns) => ps -> l -> l'-hProjectByProxies ps l = hProjectByHNats (hTypes2HNats ps l) 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 -{-----------------------------------------------------------------------------}+hDeleteAt :: forall e l n. (HDeleteAtHNat n l, HType2HNat e l n) => +	   Proxy e -> HList l -> HList (HDeleteAtHNatR n l)+hDeleteAt _p l = hDeleteAtHNat (undefined :: Proxy n) l --- | 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+hUpdateAt :: forall n e l.+		 (HUpdateAtHNat n e l, HType2HNat e l n) => +		 e -> HList l -> (HList (HUpdateAtHNatR n e l))+hUpdateAt e l = hUpdateAtHNat (undefined:: Proxy n) e l +hProjectBy :: forall (ns :: [HNat]) (ps :: [*]) (l :: [*]).+	      (HProjectByHNatsCtx ns l, HTypes2HNats ps l ns,+	      ps ~ (HProjectByHNatsR ns l)) =>+	      Proxy ps -> HList l -> HList ps+hProjectBy _ps l = hProjectByHNats (undefined::Proxy ns) l -{-----------------------------------------------------------------------------}+hSplitBy :: forall (ps :: [*]) l ns.+	    (HProjectByHNatsCtx ns l, HProjectAwayByHNatsCtx ns l,+	     HTypes2HNats ps l ns) =>+	    Proxy ps -> HList l -> (HList (HProjectByHNatsR ns l), +				    HList (HProjectAwayByHNatsR ns l))+hSplitBy _ps l = hSplitByHNats (undefined::Proxy ns) l
Data/HList/HZip.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-}  {- |    The HList library@@ -6,78 +5,116 @@    (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 -{-----------------------------------------------------------------------------}+class HZip x y l | x y -> l, l -> x y where+  hZip   :: HList x -> HList y -> HList l+  hUnzip :: HList l -> (HList x, HList y) --- | Zip and unzip+instance HZip '[] '[] '[] where+  hZip _ _ = HNil+  hUnzip _ = (HNil, HNil) -class HZip x y l | x y -> l, l -> x y- where-  hZip   :: x -> y -> l-  hUnzip :: l -> (x,y)+instance ((x,y)~z, HZip xs ys zs) => HZip (x ': xs) (y ': ys) (z ': zs) where+  hZip (HCons x xs) (HCons y ys) = (x,y) `HCons` hZip xs ys+  hUnzip (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip zs in (x `HCons` xs, y `HCons` ys) -{-+-- ** 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. --- Zipping version I+-- | 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)) --- | Test for zippability: equal length.+instance HUnZip '[] where+  type MapFst '[] = '[]+  type MapSnd '[] = '[]+  hZip2 _ _ = HNil+  hUnzip2 _ = (HNil, HNil) -class HZippable x y-instance HZippable HNil HNil-instance HZippable l l' => HZippable (HCons e l) (HCons e' l')+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)+  hZip2 _ _ = error "Data.HList.HZip.hZip2: impossible case"+  hUnzip2 (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip2 zs in (x `HCons` xs, y `HCons` ys) --- 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+-- | 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 --} -{-+-- ** 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 --- Zipping version II--- Built-in show and alias-based type construction inconvenient.--- Version III goes for a true list of pairs. -instance HZip HNil HNil (HNil,HNil)- where-  hZip x y = (x,y)-  hUnzip = id+-- * transpose -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+{- | this transpose requires equal-length HLists inside a HList: +>>> import Data.HList.HListPrelude+>>> let ex = (1 .*. 2 .*. HNil) .*. ('a' .*. 'b' .*. HNil) .*. ( 3 .*. 5 .*. HNil) .*. HNil++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,679 @@+{-# LANGUAGE OverlappingInstances, StandaloneDeriving #-}++{- | keyword functions++-}+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++  ) where++import GHC.TypeLits+import Data.HList.FakePrelude+import Data.HList.TypeEqO ()+import Data.HList.HListPrelude+import Data.HList.HList+import Data.HList.Record+import Data.HList.RecordPuns++{- $setup++ >>> :set -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses+ >>> :set -XScopedTypeVariables -XOverlappingInstances -XTypeFamilies++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++-- | All our keywords must be registered+++class IsKeyFN   t (flag :: Bool) | t-> flag+-- | overlapping/fallback case+instance (False ~ flag) => IsKeyFN t flag+instance IsKeyFN (Label (s :: Symbol) -> a -> b) True+{- ^ labels that impose no restriction on the type of the (single) argument+ which follows++ >>> 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+    kwapply' _ _ _ = error "Data.HList.Keyword.kwapply': impossible 1"++-- | Rotate the arg list ...+instance  (HAppendList tail '[kw , v] ~ l',+	   KWApply f l' r)+    => KWApply' False f (kw ': v ': tail) r where+    kwapply' _ f (HCons kw_ (HCons v tl)) =+	kwapply f (hAppend tl (kw_ .*. v .*. HNil))+    kwapply' _ _ _ = error "Data.HList.Keyword.kwapply': impossible 2"++{- |++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'' (undefined:: 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)))+    kwmerge'' _ _ _ _ = error "Data.HList.kwmerge'': impossible"+instance KWMerge' kw tail atail arg_values arg_def f r+    => KWMerge'' False kw (kw' ': v' ': tail)+                 atail arg_values arg_def f r where+    kwmerge'' _ kw_ (HCons _ (HCons _ tl)) = kwmerge' kw_ tl+    kwmerge'' _ _ _ = error "Data.HList.kwmerge'': impossible 2"++-- | Add the real argument to the Arg structure, and continue++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 LVPairToKW = LVPairToKW+instance (x ~ LVPair l v, y ~ HList '[Label l, v]) =>+        ApplyAB LVPairToKW x y where+    applyAB _ (LVPair v) = hBuild Label v+++{- | convert a 'Record' into a list that can supply+default arguments for 'kw'++A bit of setup:++>>> :set -XQuasiQuotes+>>> 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. (HMapAux LVPairToKW a b, SameLength a b,+      SameLength b a, HConcat b) =>+     Record a -> HList (HConcatR b)+recToKW (Record r) = hConcat (hMap LVPairToKW 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,8 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, EmptyDataDecls #-}  {- |++   Description : namespaced labels+    The HList library     (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke@@ -23,7 +25,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 +35,43 @@ module Data.HList.Label3 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+data Lbl (x :: HNat) ns desc  -- labels are exclusively type-level entities   -- Public constructors for labels  -- | Construct the first label-firstLabel :: ns -> desc -> Label HZero ns desc+firstLabel :: ns -> desc -> Label (Lbl HZero ns desc) firstLabel = undefined   -- | Construct the next label-nextLabel :: Label x ns desc -> desc' -> Label (HSucc x) ns desc'+nextLabel :: Label (Lbl x ns desc) -> desc' -> Label (Lbl (HSucc x) ns desc') nextLabel = undefined   -- | 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+      where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs             getd = undefined -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+      where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs             getd = undefined
− 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 
@@ -1,42 +0,0 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}--{- |-   The HList library--   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke--   Yet another model of labels.--   This model allow us to use any type as label type.-   As a result, we need some generic instances.--   Also, type errors may be more confusing now.--}--module Data.HList.Label5 where--import Data.Typeable-import Data.Char-import Data.HList.FakePrelude-import Data.HList.Record----- | Equality on labels--instance TypeEq x y b => HEq x y b----- | Show label--instance Typeable x => ShowLabel x- where-  showLabel = (\(x:xs) -> toLower x:xs)-            . reverse-            . takeWhile (not . (==) '.')-            . reverse-            . show-{--            . tyConString-            . typeRepTyCon--}-            . typeOf
+ Data/HList/Label6.hs view
@@ -0,0 +1,25 @@+{- |+   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#label6demo" for an example.++-}++module Data.HList.Label6 () where++import Data.HList.FakePrelude+import GHC.TypeLits++instance SingI x => ShowLabel (x :: Symbol) where+  showLabel _ =  fromSing (sing :: Sing x)+
+ Data/HList/Labelable.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{- |++Description : labels which are also lenses++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+    (makeLabelable,+     Labelable(hLens'),+     (.==.),++    -- * comparison with 'hLens'+    -- $comparisonWithhLensFunction++    -- * likely unneeded (re)exports+    -- $note needed to make a needed instance visible+    Labeled(Labeled),+    toLabel,+    Identity,+    ToSym,+    ) where+++import Data.HList.FakePrelude+import Data.HList.HArray+import Data.HList.HList+import Data.HList.Record++import Control.Monad.Identity+import GHC.TypeLits++import Language.Haskell.TH++{- | @f s t a b@ type parameters are the same as those that make+"Control.Lens" work.++[@n@] is the index in the HList at which the value will be found++[@l@] is the label for the field (tends to be 'GHC.TypeLits.Symbol')++[@p@] is @->@ when the result is used as a lens, or 'Labeled' when used+      as an argument to '.==.'++-}+class Labelable l p f s t a b+#if MIN_VERSION_base(4,7,0)+     {- no fundeps in this case: they are potentially inconsistent+        according to ghc-7.8+        <http://ghc.haskell.org/trac/ghc/ticket/2247>++        these fundeps are mostly documentation, since the two+        instances have contexts that encode roughly the same+        dependencies provided you choose a specific `p'+     -}+#else+        | l s -> a, l t -> b,     -- lookup+          l s b -> t, l t a -> s  -- update+#endif+  where+    hLens' :: Label l -> p (a -> f b) (Record s -> f (Record t))++data Labeled (l :: k) (a :: *) (b :: *) = Labeled deriving (Show)++-- | make a lens+instance (Functor f,+          HasField x (Record s) a,+          HasField x (Record t) b,+          HFind x (RecordLabels t) n,+          HFind x (RecordLabels s) n,+          HUpdateAtHNat n (LVPair x b) s,+          t ~ HUpdateAtHNatR n (LVPair x b) s)+        => Labelable x (->) f s t a b where+            hLens' lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab))++-- | make a data type that allows recovering the field name+instance (f ~ Identity, s ~ '[], t ~ '[], a ~ (), b ~ (),+           x' ~ x) => Labelable x' (Labeled x) f s t a b where+        hLens' _ = Labeled :: Labeled x (a -> f b) (Record s -> f (Record t))+++-- | 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+++-- | extracts the type that is actually the label in @a@ and puts it in @b@+class ToSym a b++-- | for labels in this module+instance (x ~ x', p ~ Labeled x') => ToSym (p a b) x'++-- | for "Data.HList.Label6" labels+instance (x ~ x') => ToSym (Label x) x'++toLabel :: ToSym t t' => t -> Label (t' :: Symbol)+toLabel _ = Label++++{- | @makeLabelable \"x y z\"@ will generate haskell identifiers that work with '.==.' and+are also lenses.++> x = hLens' (Label :: Label "x")+> y = hLens' (Label :: Label "y")+> z = hLens' (Label :: Label "z")++-}+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| Labelable $l p f s t a b => p (a -> f b) (Record s -> f (Record t)) |]+++{- $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 .~ "6"+ >        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.++-}
Data/HList/MakeLabels.hs view
@@ -1,111 +1,124 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TemplateHaskell, FlexibleInstances, EmptyDataDecls #-}+{-# 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,+    makeLabels6,+    -- | see also 'Data.HList.Labelable.makeLabelable'+    ) where ->  $(makeLabels ["getX","getY","draw"])+import Data.HList.FakePrelude+import Data.HList.Label3 -should expand into the following declarations+import Language.Haskell.TH+import Data.Char+import Control.Monad -> data GetX;     getX     = proxy::Proxy GetX-> data GetY;     getY     = proxy::Proxy GetY-> data Draw;     draw     = proxy::Proxy Draw+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" --}+make_dname (x:xs) = mkName (toLower x : xs)+make_dname _ = error "Data.HList.MakeLabels.make_dname: empty string" -module Data.HList.MakeLabels (makeLabels,label) where+dcl :: String -> Q [Dec]+dcl n = let+    c = make_cname n+    d = make_dname n -import Data.HList.FakePrelude+    dd = dataD (return []) c [] [] [{- 'Typeable -}] -import Language.Haskell.TH.Ppr (pprint)-import Language.Haskell.TH.Syntax+    labelSig = sigD d [t| Label $(conT c) |] -import Data.Char (toUpper, toLower)-import Control.Monad (liftM)+    labelDec = valD+                  (varP d)+                  (normalB [| Label |])+                  [] -import Data.Typeable (Typeable)+    showLabelInst = instanceD+            (return [])+            [t| ShowLabel $(conT c) |]+            [valD (varP 'showLabel)+                (normalB [| \_ -> n |])+                [] ] -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+        showLabelInst,+        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.Label4" used to provide (only no Typeable). -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+> data LabelGetY+> data LabelDraw+> data LabelX -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  -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))+> instance ShowLabel LabelGetX where showLabel = \_ -> "getX"+> instance ShowLabel LabelGetY where showLabel = \_ -> "getY"+> instance ShowLabel LabelDraw where showLabel = \_ -> "draw" --- | 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)+makeLabels = fmap concat . mapM dcl --- | Make a single label-label :: String -> Q [Dec]-label s = makeLabels [s] --- Show the code expression-show_code cde = runQ cde >>= putStrLn . pprint+-- | 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) -{--t1 = show_code [d| data Foo |]+        sq1 = valD (varP (make_dname k))+                (normalB [| firstLabel (undefined :: $(conT (make_cname ns)))+                                       (undefined :: $(conT (make_cname k))) |])+                [] -t2 = showName $ mkName "Foo"+        sqs = [ valD (varP (make_dname k2))+                (normalB [| nextLabel $(varE (make_dname k1))+                                    (undefined :: $(conT (make_cname k2))) |])+                [] -t3 = show_code $-     liftM (replace_name-            (make_tname "foo",make_dname "foo")-            (make_tname "bar",make_dname "bar")) dcl_template--}+                | (k1,k2) <- zip (k:ks) ks ] -t4 = show_code $ makeLabels ["getX","getY","draw"]+    in fmap concat $ sequence [ pt1, sequence (sq1 : sqs) ]+-- possibly there is a better option+makeLabels3 ns [] = fail ("makeLabels3 "++ ns ++ " []")++-- | for "Data.HList.Label6"+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 |]) []]
Data/HList/Record.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  {- |    The HList library@@ -9,22 +6,30 @@     Extensible records -   The are different models of labels that go with this module;-   see:+   The three-ish models of labels that go with this module; +   * "Data.HList.Label3"++   * "Data.HList.MakeLabels"+++   These used to work:+    * "Data.HList.Label1"     * "Data.HList.Label2" -   * "Data.HList.Label3"-    * "Data.HList.Label4"     * "Data.HList.Label5"+ -}  module Data.HList.Record (+    -- ** labels used for doctests+    -- $setup+     -- * Records      -- ** Labels@@ -32,6 +37,7 @@     LVPair(..),     labelLVPair,     newLVPair,+    (.=.), (.-.),      -- ** Record     Record(..),@@ -41,8 +47,10 @@     -- *** Getting Labels     RecordLabels,     recordLabels,-    recordLabels', +    LabelsOf,+    hLabels,+     -- *** Getting Values     RecordValues(..),     recordValues,@@ -55,17 +63,28 @@     ShowComponents(..),     ShowLabel(..), -    -- ** Lookup-    HasField(..),-    HasField'(..),      -- ** Delete     -- | 'hDeleteAtLabel' @label record@     hDeleteAtLabel, +    -- ** Lookup/update+    -- $lens+    hLens,++    -- ** Lookup+    HasField(..),+    HasField'(..),+    (.!.),+     -- ** Update-    -- | 'hUpdateAtLabel' @label value record@+    (.@.),     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,      -- ** Rename Label@@ -80,22 +99,28 @@     -- *** Left     HLeftUnion(hLeftUnion),     HLeftUnionBool(hLeftUnionBool),+    (.<++.),      -- *** Symmetric     -- $symmetricUnion     UnionSymRec(unionSR), +     -- ** Reorder Labels     hRearrange,      -- ** Extension     -- | 'hExtend', 'hAppend'+    (.*.), -    -- * Unclassified-    -- | Probably internals, that may not be useful-    DuplicatedLabel(..),++    -- * Hints for type errors+    DuplicatedLabel,     ExtraField(..),     FieldNotFound(..),++    -- * Unclassified+    -- | Probably internals, that may not be useful     H2ProjectByLabels(h2projectByLabels),     H2ProjectByLabels'(h2projectByLabels'),     HLabelSet,@@ -110,11 +135,23 @@  import Data.HList.FakePrelude import Data.HList.HListPrelude+import Data.HList.HList import Data.HList.HArray+ +-- 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@@ -122,144 +159,184 @@ -- labels is erased.  -- | Field of label l with value type v+-- Polykinded with respect to l: label may be a symbol, a nat, etc. newtype LVPair l v = LVPair { valueLVPair :: v } deriving Eq  -- | Label accessor-labelLVPair :: LVPair l v -> l+labelLVPair :: LVPair l v -> Label l labelLVPair = undefined -newLVPair :: l -> v -> LVPair l v+newLVPair :: Label l -> v -> LVPair l v newLVPair _ = LVPair -newtype Record r = Record r deriving Eq+-- stolen by typeable+--infixr 4 :=:+--type l :=: v = LVPair l v  +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 -> LVPair l v+l .=. v = newLVPair l v+++newtype Record (r :: [*]) = Record (HList r) -- deriving Eq++ -- | Build a record-mkRecord :: HRLabelSet r => r -> Record r+mkRecord :: HRLabelSet r => HList r -> Record r mkRecord = Record   -- | Build an empty record-emptyRecord :: Record HNil+emptyRecord :: Record '[] 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)+data DuplicatedLabel l++class HRLabelSet (ps :: [*])+instance HRLabelSet '[]+instance HRLabelSet '[x] instance ( HEq l1 l2 leq-         , HRLabelSet' l1 v1 l2 v2 leq r-         ) => HRLabelSet (HCons (LVPair l1 v1) (HCons (LVPair l2 v2) r))+         , HRLabelSet' l1 l2 leq r+         ) => HRLabelSet (LVPair l1 v1 ': 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+class HRLabelSet' l1 l2 (leq::Bool) (r :: [*])+instance ( HRLabelSet (LVPair l2 () ': r)+         , HRLabelSet (LVPair l1 () ': r)+         ) => HRLabelSet' l1 l2 False r+instance ( Fail (DuplicatedLabel l1) ) => HRLabelSet' l1 l2 True r ++-- | Relation between HLabelSet and HRLabelSet {- instance (HZip ls vs ps, HLabelSet ls) => HRLabelSet ps -}  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+instance HLabelSet '[]+instance HLabelSet '[x]+instance ( HEq l1 l2 leq+         , HLabelSet' l1 l2 leq r+         ) => HLabelSet (l1 ': l2 ': r) -data DuplicatedLabel l = DuplicatedLabel l-instance Fail (DuplicatedLabel x) => HLabelSet' x ls HTrue+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 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+type family RecordLabels (r :: [*]) :: [k]+type instance RecordLabels '[]               = '[]+type instance RecordLabels (LVPair l v ': r) = l ': RecordLabels r -recordLabels :: RecordLabels r ls => Record r -> ls-recordLabels (Record r) = recordLabels' r+recordLabels :: Record r -> Proxy (RecordLabels r)+recordLabels = undefined --- | 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+-- | Construct the HList of values of the record.+class RecordValues (r :: [*]) where+  type RecordValuesR r :: [*]+  recordValues' :: HList r -> HList (RecordValuesR r)++instance RecordValues '[] where+  type RecordValuesR '[] = '[]+  recordValues' _ = HNil+instance RecordValues r=> RecordValues (LVPair l v ': r) where+   type RecordValuesR (LVPair l v ': r) = v ': RecordValuesR r+   recordValues' (HCons (LVPair v) r) = HCons v (recordValues' r)++recordValues :: RecordValues r => Record r -> HList (RecordValuesR r) recordValues (Record r) = recordValues' r  +-- | Making this ls::[*] and [k] breaks the MainGhcGeneric1.hs...+type family LabelsOf (ls :: [*]) :: [*]+type instance LabelsOf '[] = '[]+type instance LabelsOf (Label l ': r)  = l ': LabelsOf r -{-----------------------------------------------------------------------------}+hLabels :: HList l -> Proxy (LabelsOf l)+hLabels = undefined +-- --------------------------------------------------------------------------+ -- 'Show' instance to appeal to normal records -instance ShowComponents r => Show (Record r)- where+instance ShowComponents r => Show (Record r) where   show (Record r) =  "Record{"                   ++ showComponents "" r                   ++ "}" -class ShowComponents l- where-  showComponents :: String -> l -> String+class ShowComponents l where+  showComponents :: String -> HList l -> String -instance ShowComponents HNil- where-  showComponents _ HNil = ""+instance ShowComponents '[] where+  showComponents _ _ = ""  instance ( ShowLabel l          , Show v          , ShowComponents r          )-      =>   ShowComponents (HCons (LVPair l v) r)- where+      =>   ShowComponents (LVPair l v ': r) where   showComponents comma (HCons f@(LVPair v) r)      =  comma-     ++ showLabel (labelLVPair f)+     ++ showLabel ((labelLVPair f) :: Label l)      ++ "="      ++ 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)+instance HRLabelSet (LVPair l v ': r) +    => HExtend (LVPair (l :: k) v) (Record r) where+  type HExtendR (LVPair l v) (Record r) = Record (LVPair l v ': 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 r''-         , HAppend r r' r''-         )-    => HAppend (Record r) (Record r') (Record r'')- where+instance (HRLabelSet (HAppendList r1 r2), HAppend (HList r1) (HList r2))+    => HAppend (Record r1) (Record r2) where+  type HAppendR (Record r1) (Record r2) = Record (HAppendList r1 r2)   hAppend (Record r) (Record r') = mkRecord (hAppend r r') --{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------  -- Lookup --@@ -270,66 +347,139 @@ -- | 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+class HasField (l::k) r v | l r -> v where+    hLookupByLabel:: Label l -> r -> v -{--instance ( RecordLabels r ls+{- alternative "straightforward" implementation+instance ( RecordLabels r ~ ls          , HFind l ls n-         , HLookupByHNat n r (LVPair l v)+         , HLookupByHNat n r+         , HLookupByHNatR 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-+        (LVPair v) = hLookupByHNat (proxy :: Proxy n) r -}   -instance HasField l r v => HasField l (Record r) v where-    hLookupByLabel l (Record r) = hLookupByLabel l r+instance (HEq l l1 b, HasField' b l (LVPair l1 v1 ': r) v)+    => HasField l (Record (LVPair l1 v1 ': r)) v where+    hLookupByLabel l (Record r) =+             hLookupByLabel' (undefined::Proxy b) 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+class HasField' (b::Bool) (l :: k) (r::[*]) v | b l r -> v where+    hLookupByLabel':: Proxy b -> Label l -> HList r -> v -instance HasField' HTrue l (HCons (LVPair l v) r) v where+instance HasField' True l (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+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 -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+hDeleteAtLabel :: forall l t t1 t2. +   (H2ProjectByLabels '[l] t t1 t2) =>+   Label l -> Record t -> Record t2+hDeleteAtLabel _ (Record r) = +  Record $ snd $ h2projectByLabels (undefined::Proxy '[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 '[l] r _r' r') =>+    Record r -> Label l -> Record r'+r .-. l =  hDeleteAtLabel l 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+-- | 'hUpdateAtLabel' @label value record@+hUpdateAtLabel :: forall (r :: [*]) (l :: k) (n::HNat) (v :: *). +  (HFind l (RecordLabels r) n, HUpdateAtHNat n (LVPair l v) r) =>+  Label l -> v -> Record r -> Record (HUpdateAtHNatR n (LVPair l v) r)+hUpdateAtLabel l v (Record r) = +    Record (hUpdateAtHNat (undefined::Proxy n) (newLVPair l v) 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@(LVPair v) .@. r  =  hUpdateAtLabel (labelLVPair f) v r+++-- -------------------------------------------------------------------------- -- Projection  -- $projection@@ -338,11 +488,14 @@   -- | @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 :: (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) =>ls -> Record t -> (Record t1, Record t2)+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 @@ -351,59 +504,57 @@ --  > 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)+class H2ProjectByLabels (ls::[k]) r rin rout | ls r -> rin rout where+    h2projectByLabels :: Proxy ls -> HList r -> (HList rin,HList rout) -instance H2ProjectByLabels HNil r HNil r where+instance H2ProjectByLabels '[] r '[] r where     h2projectByLabels _ r = (HNil,r) -instance H2ProjectByLabels (HCons l ls) HNil HNil HNil where+instance H2ProjectByLabels (l ': ls) '[] '[] '[] 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+instance (HMemberM l1 ((l::k) ': ls) (b :: Maybe [k]),+          H2ProjectByLabels' b (l ': ls) (LVPair l1 v1 ': r1) rin rout)+    => H2ProjectByLabels (l ': ls) (LVPair l1 v1 ': r1) rin rout where+    h2projectByLabels = h2projectByLabels' (undefined::(Proxy b)) -class H2ProjectByLabels' b ls r rin rout | b ls r -> rin rout where-    h2projectByLabels' :: b -> ls -> r -> (rin,rout)+class H2ProjectByLabels' (b::Maybe [k]) (ls::[k]) r rin rout +                         | b ls r -> rin rout where+    h2projectByLabels' :: Proxy b -> Proxy ls -> +				     HList r -> (HList rin,HList rout) -instance H2ProjectByLabels ls' r' rin rout =>-    H2ProjectByLabels' (HJust ls') ls (HCons f' r') (HCons f' rin) rout where+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 (undefined::ls') r+        where (rin,rout) = h2projectByLabels (undefined::Proxy ls1) r -instance H2ProjectByLabels ls r' rin rout =>-    H2ProjectByLabels' HNothing ls (HCons f' r') rin (HCons f' rout) where+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=()} --- | 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'+  r'' = 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)+   _te :: a -> a -> ()+   _te _ _ = ()+   _ = _te v (hLookupByLabel l r)  {- ^ @@ -416,49 +567,64 @@  -} -{-----------------------------------------------------------------------------}+infixr 2 .<.+{-|+  The same as '.@.', except type preserving. It has the same fixity as (.\@.). +-}+f@(LVPair v) .<. r = hTPupdateAtLabel (labelLVPair f) v r++-- -------------------------------------------------------------------------- -- | Subtyping for records-instance ( RecordLabels r' ls-         , H2ProjectByLabels ls r r' rout-         )-    => SubType (Record r) (Record r') +instance H2ProjectByLabels (RecordLabels r2) r1 r2 rout+    => SubType (Record r1) (Record r2) -{-----------------------------------------------------------------------------} +-- --------------------------------------------------------------------------+ -- Left Union  class  HLeftUnion r r' r'' | r r' -> r''- where hLeftUnion :: r -> r' -> r''+ where hLeftUnion :: Record r -> Record r' -> Record r'' -instance HLeftUnion r (Record HNil) r+instance HLeftUnion r '[] r  where   hLeftUnion r _ = r -instance ( RecordLabels r ls+instance ( RecordLabels r ~ ls          , HMember l ls b          , HLeftUnionBool b r (LVPair l v) r'''-         , HLeftUnion (Record r''') (Record r') r''+         , HLeftUnion r''' r' r''          )-           => HLeftUnion (Record r) (Record (HCons (LVPair l v) r')) r''+           => HLeftUnion r (LVPair l v ': r') r''   where-   hLeftUnion (Record r) (Record (HCons f r')) = r''+   hLeftUnion r (Record (HCons f r')) = r''     where-     b       = hMember (labelLVPair f) (recordLabels' r)-     r'''    = hLeftUnionBool b r f-     r''     = hLeftUnion (Record r''') (Record r')+     r'''    = hLeftUnionBool (proxy :: Proxy b) r f+     r''     = hLeftUnion (r''' :: Record r''') (Record r' :: Record r') -class  HLeftUnionBool b r f r' | b r f -> r'- where hLeftUnionBool :: b -> r -> f -> r'+class  HLeftUnionBool (b :: Bool) r f r' | b r f -> r'+ where hLeftUnionBool :: Proxy b -> Record r -> f -> Record r' -instance HLeftUnionBool HTrue r f r+instance HLeftUnionBool True r f r    where hLeftUnionBool _ r _  = r -instance HLeftUnionBool HFalse r f (HCons f r)-   where hLeftUnionBool _ r f = HCons f r+instance HLeftUnionBool False r f (f ': r)+   where hLeftUnionBool _ (Record r) f = Record (HCons f 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).@@ -486,83 +652,105 @@ -- to r1. Ditto for r2.  class UnionSymRec r1 r2 ru | r1 r2 -> ru where-    unionSR :: r1 -> r2 -> (ru, ru)+    unionSR :: Record r1 -> Record r2 -> (Record ru, Record ru) -instance UnionSymRec r1 (Record HNil) r1 where+instance UnionSymRec r1 '[] r1 where     unionSR r1 _ = (r1, r1) -instance ( RecordLabels r1 ls+instance ( RecordLabels r1 ~ ls          , HMember l ls b-         , UnionSymRec' b (Record r1) (LVPair l v) (Record r2') ru+         , UnionSymRec' b r1 (LVPair l v) r2' ru          )-    => UnionSymRec (Record r1) (Record (HCons (LVPair l v) r2')) ru+    => UnionSymRec r1 (LVPair l v ': r2') ru     where     unionSR r1 (Record (HCons f r2')) =-        unionSR' (undefined::b) r1 f (Record r2')+        unionSR' (undefined::Proxy 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)+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' (Record ru),-          HasField l2 ru v2,-          HUpdateAtHNat n (LVPair l2 v2) ru ru,-          RecordLabels ru ls,+-}+instance (UnionSymRec r1 r2' ru,+          HasField l2 (Record ru) v2,+          HUpdateAtHNat n (LVPair l2 v2) ru,+          ru ~ HUpdateAtHNatR n (LVPair l2 v2) ru,+          RecordLabels ru ~ ls,+          f2 ~ LVPair l2 v2,           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+    => UnionSymRec' True r1 f2 r2' ru where+    unionSR' _ r1 (LVPair v2) r2' =+       case unionSR r1 r2'+        of (ul,ur) -> (ul, hTPupdateAtLabel (undefined:: Label 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+instance (UnionSymRec r1 r2' ru,+          HExtend f2 (Record ru),+          HExtendR f2 (Record ru) ~ Record f2ru)+    => UnionSymRec' False r1 f2 r2' f2ru where     unionSR' _ r1 f2 r2' = (ul', ur')        where (ul,ur) = unionSR r1 r2'-             ul' = hExtend f2 ul-             ur' = hExtend f2 ur+             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. (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+hRearrange :: (HLabelSet ls, HRearrange ls r (HList r')) => Proxy 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'+class HRearrange ls r r' where+    hRearrange2 :: Proxy ls -> HList r -> r' -instance HRearrange HNil HNil HNil where+instance (HList '[] ~ r) => HRearrange '[] '[] r 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+instance (H2ProjectByLabels '[l] r rin rout,+          HRearrange' l ls rin rout (HList r'),+          r'' ~ HList r') =>+        HRearrange (l ': ls) r r'' where+   hRearrange2 _ r = hRearrange2' (proxy :: Proxy l) (proxy :: Proxy ls) rin rout+      where (rin, rout) = h2projectByLabels (proxy :: Proxy '[l]) 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)+class HRearrange' l ls rin rout r' where+    hRearrange2' :: Proxy l -> Proxy ls -> HList rin -> HList rout -> r'+ +instance (HRearrange ls rout (HList r'),+         r'' ~ HList (LVPair l v ': r')) =>+        HRearrange' l ls '[LVPair l v] rout 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+        HRearrange' l ls '[] rout (FieldNotFound l) where    hRearrange2' _ _ _ _ = FieldNotFound  -- | For improved error messages instance Fail (ExtraField l) => -          HRearrange HNil (HCons (LVPair l v) a) (ExtraField l) where+          HRearrange '[] (LVPair l v ': a) (ExtraField l) where    hRearrange2 _ _ = ExtraField+++-- --------------------------------------------------------------------------+-- $lens+-- Lens-based setters/getters are popular.+--+-- This is a provisional method to make a @Lens (Record s) (Record t) a b@,+-- out of a 'Label' @x@. Refer to @examples/lens.hs@ for an example.+hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab)) +
− 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,158 @@+{-# 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+++{- $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. The idea is that variables inside+@{ }@ are in another record. More concretely:++> [pun| ab@{ a b } y z c{d} |]++as a pattern, it will bindings from an original record @x@,+if you interpret (.) as a left-associative field lookup (as it+is in other languages):++> let ab = xab+>     a = x.ab.a+>     b = x.ab.b+>     y = x.y+>     z = x.z+>     -- c is not bound+>     d = x.c.d++as an expression, it creates a new record which needs the variables+@ab a b y z d@ in-scope. @ab@ needs to be a record, and if it has+fields called @a@ or @b@ they are overridden by the values of @a@ and @b@+which are in scope.++See also @examples/pun.hs@.+-}+++-- | requires the use of "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@)+pun :: QuasiQuoter+pun = QuasiQuoter {+    quotePat = mp . parseRec,+    quoteExp = me . parseRec,+    quoteDec  = error "Data.HList.RecordPuns.quoteDec",+    quoteType = error "Data.HList.RecordPuns.quoteType"+ }+++-- like  \x -> (x .!. x1, x .!. x2)+extracts xs = do+    record <- newName "record"+    lamE [varP record]+        (tupE+            [ [| $(varE record) .!. $label  |]+                | x <- xs,+                let label = [| Label :: Label $(litT (strTyLit x)) |]+                ])++mkExp :: [String] -> ExpQ+mkExp xs = foldr (\x acc -> [| $(mkPair x (dyn x)) .*. $acc |]) [| emptyRecord |] xs++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 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 : 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) = case unzip (mps as) of+    (a, b) -> viewP (extracts a) (tupP b)+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 : 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] | V String 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}}"++-}+parseRec :: String -> Tree+parseRec str = case parseRec' 0 [[]] $ lexing str of+    [x] -> x -- avoid adding another layer if possible+    x -> C (reverse x)++parseRec' :: Int -> [[Tree]] -> [String] -> [Tree]+parseRec' n accum  ("{" : rest)  = parseRec' (n+1) ([] : accum) rest+parseRec' n (a:b:c) ("}" : rest) = parseRec' (n-1) ((C (reverse a) : b) : c)  rest+parseRec' n (b:c) (a   : rest)+         | a `notElem` ["{","}"] = parseRec' n     ((V a : b) : c) rest+parseRec' 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 (V x)  = x++lexing = unfoldr (\v -> case lex v of+                    ("", "") : _ -> Nothing+                    e : _ -> Just e+                    _ -> Nothing)
Data/HList/TIC.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}  {- |    The HList library@@ -6,32 +9,29 @@    (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke     Type-indexed co-products.++   (There are other ways: see ConsUnion.hs, for example) -}  module Data.HList.TIC where  import Data.Dynamic -import Data.HList.FakePrelude-import Data.HList.HListPrelude-import Data.HList.HOccurs+import Data.HList.HList import Data.HList.TIP  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- | A datatype for type-indexed co-products -data TIC l = TIC Dynamic+newtype TIC (l :: [*]) = TIC Dynamic  -{-----------------------------------------------------------------------------}---- | Public constructor+-- --------------------------------------------------------------------------+-- | Public constructor (or, open union's injection function)  mkTIC :: ( HTypeIndexed l-         , HTypeProxied l-         , HOccurs (Proxy i) l+         , HMember i l True          , Typeable i          )       => i -> TIC l@@ -39,13 +39,11 @@ mkTIC i = TIC (toDyn i)  -{-----------------------------------------------------------------------------}---- | Public destructor+-- --------------------------------------------------------------------------+-- | Public destructor (or, open union's projection function)  unTIC :: ( HTypeIndexed l-         , HTypeProxied l-         , HOccurs (Proxy o) l+         , HMember o l True          , Typeable o          )       => TIC l -> Maybe o@@ -53,22 +51,10 @@ unTIC (TIC i) = fromDynamic i  -{-----------------------------------------------------------------------------}---- | 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)---{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- | TICs are opaque  instance Show (TIC l)  where   show _ = "<Cannot show TIC content!>" --{-----------------------------------------------------------------------------}
Data/HList/TIP.hs view
@@ -1,6 +1,3 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances,-    FlexibleContexts #-}  {- |    The HList library@@ -13,247 +10,157 @@ module Data.HList.TIP where  -import Data.HList.FakePrelude import Data.HList.HListPrelude-import Data.HList.HArray-import Data.HList.HOccurs+import Data.HList.HList+import Data.HList.HArray () import Data.HList.HTypeIndexed +import Data.HList.TypeEqO () -- for doctest -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------+-- * The newtype for type-indexed products --- | The newtype for type-indexed products+newtype TIP (l :: [*]) = TIP{unTIP:: HList l} -newtype TIP l = TIP l-        deriving (Read,Show)+instance Show (HList l) => Show (TIP l) where+  show (TIP l) = "TIP" ++ show l -mkTIP :: HTypeIndexed l => l -> TIP l+mkTIP :: HTypeIndexed l => HList l -> TIP l mkTIP = TIP -unTIP :: TIP l -> l-unTIP (TIP l) = l--emptyTIP :: TIP HNil+emptyTIP :: TIP '[] emptyTIP = mkTIP HNil -+-- --------------------------------------------------------------------------+-- * Type-indexed type sequences -{-----------------------------------------------------------------------------}+class HTypeIndexed (l :: [*])+instance HTypeIndexed '[]+instance (HOccursNot e l,HTypeIndexed l) => HTypeIndexed (e ': l) --- | Type-indexed type sequences+-- --------------------------------------------------------------------------+-- Implementing the HListPrelude interface -class HList l => HTypeIndexed l-instance HTypeIndexed HNil-instance (HOccursNot e l,HTypeIndexed l) => HTypeIndexed (HCons e l)+instance (HOccursNot e l, HTypeIndexed l) => HExtend e (TIP l) + where+  type HExtendR e (TIP l) = TIP (e ': l)+  e .*. TIP l = mkTIP (HCons e l)  -{-----------------------------------------------------------------------------}------- One occurrence and nothing is left+-- | 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 e' ~ e => HOccurs e' (TIP '[e]) where+  hOccurs (TIP (HCons e' _)) = e' -instance HOccurs e (HCons x (HCons y l))-      => HOccurs e (TIP (HCons x (HCons y l)))- where+instance HOccurs e (HList (x ': y ': l))+      => HOccurs e (TIP (x ': y ': l)) where   hOccurs (TIP l) = hOccurs l  -{-----------------------------------------------------------------------------}---- HOccursNot lifted to TIPs- instance HOccursNot e l => HOccursNot e (TIP l)  -{-----------------------------------------------------------------------------}---- | 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--Valid type I--hExtend' :: (HTypeIndexed l, HOccursNot e l)-         => e -> TIP l -> TIP (HCons e l)--Valid type II--*TIP> :t hExtend'-hExtend' :: forall l e.-            (HTypeIndexed (HCons e l)) =>-            e -> TIP l -> TIP (HCons e l)---}---{-----------------------------------------------------------------------------}---- Lift extension through HExtend--instance ( HOccursNot e l-         , HTypeIndexed l-         )-      => HExtend e (TIP l) (TIP (HCons e l))- where-  hExtend = hExtend'---{-----------------------------------------------------------------------------}---- Lifting previous operations---instance ( HAppend l l' l''-         , HTypeIndexed l''-         )-           => HAppend (TIP l) (TIP l') (TIP l'')+instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendList l l'))+           => HAppend (TIP l) (TIP l')  where+  type HAppendR (TIP l) (TIP l') = TIP (HAppendList l l')   hAppend (TIP l) (TIP l') = mkTIP (hAppend l l')  -instance HOccursMany e l-      => HOccursMany e (TIP l)- where-  hOccursMany = hOccursMany . unTIP---instance HOccursMany1 e l-      => HOccursMany1 e (TIP l)- where-  hOccursMany1 = hOccursMany1 . unTIP---instance HOccursFst e l-      => HOccursFst e (TIP l)- where-  hOccursFst = hOccursFst . unTIP---instance HOccursOpt e l-      => HOccursOpt e (TIP l)- where-  hOccursOpt = hOccursOpt . unTIP---{-----------------------------------------------------------------------------}+-- instance HOccurrence e l l' => HOccurrence e (TIP l) l'+--  where+--   hOccurrence e = hOccurrence e . unTIP --- | Shielding type-indexed operations--- The absence of signatures is deliberate! They all must be inferred.+-- --------------------------------------------------------------------------+-- * Shielding type-indexed operations+-- $note The absence of signatures is deliberate! They all must be inferred.  onTIP f (TIP l) = mkTIP (f l) -tipyDelete  p t  = onTIP (hDeleteAtProxy p) t-tipyUpdate  e t  = onTIP (hUpdateAtType e) t-tipyProject ps t = onTIP (hProjectByProxies ps) t+tipyDelete  p t  = onTIP (hDeleteAt p) t+tipyUpdate  e t  = onTIP (hUpdateAt e) t+tipyProject ps t = onTIP (hProjectBy ps) t  --- Split produces two TIPs+-- | Split produces two TIPs tipySplit ps (TIP l) = (mkTIP l',mkTIP l'')  where-  (l',l'') = hSplitByProxies ps l+  (l',l'') = hSplitBy ps l  -{-----------------------------------------------------------------------------}+-- -------------------------------------------------------------------------- --- Subtyping for TIPs+-- | Subtyping for TIPs -instance SubType (TIP l) (TIP HNil)-instance (HOccurs e l, SubType (TIP l) (TIP l'))-      =>  SubType (TIP l) (TIP (HCons e l'))+instance SubType (TIP l) (TIP '[])+instance (HOccurs e (TIP l1), SubType (TIP l1) (TIP l2))+      =>  SubType (TIP l1) (TIP (e ': l2))  -{-----------------------------------------------------------------------------}+-- --------------------------------------------------------------------------  -- * Sample code -{- $sampleCode+{- $setup -Assume+[@Assume@] -> myTipyCow = TIP myAnimal+>>> import Data.HList.FakePrelude -> animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key-> animalKey = 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 =  '[Key,Name,Breed,Price]+:} -Session log+>>> :{+let myAnimal :: HList Animal+    myAnimal = hBuild (Key 42) (Name "Angus") Cow (Price 75.5)+    myTipyCow = TIP myAnimal+    animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key+    animalKey = hOccurs+:} -> *TIP> :t myTipyCow-> myTipyCow :: TIP Animal+-} -> *TIP> hOccurs myTipyCow :: Breed-> Cow+{- $sessionlog+[@Session log@] -> *TIP> hExtend BSE myTipyCow-> TIP (HCons BSE->     (HCons (Key 42)->     (HCons (Name "Angus")->     (HCons Cow->     (HCons (Price 75.5)->      HNil)))))+>>> :t myTipyCow+myTipyCow :: TIP Animal -> *TIP> BSE .*. myTipyCow-> --- same as before ---+>>> hOccurs myTipyCow :: Breed+Cow -> *TIP> Sheep .*. myTipyCow-> Type error ...+>>> BSE .*. myTipyCow+TIPH[BSE, Key 42, Name "Angus", Cow, Price 75.5] -> *TIP> Sheep .*. tipyDelete myTipyCow (HProxy::HProxy Breed)->TIP (HCons Sheep (HCons (Key 42) (HCons (Name "Angus") (HCons (Price 75.5) HNil)))) -> *TIP> tipyUpdate myTipyCow Sheep-> TIP (HCons (Key 42) (HCons (Name "Angus") (HCons Sheep (HCons (Price 75.5) HNil)))) --}+>>> Sheep .*. tipyDelete (proxy::Proxy Breed) myTipyCow+TIPH[Sheep, Key 42, Name "Angus", Price 75.5] -{-----------------------------------------------------------------------------}+>>> tipyUpdate Sheep myTipyCow+TIPH[Key 42, Name "Angus", Sheep, Price 75.5] --- * Sample 2+-} --- |--- 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 -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)--tuple (TIP l) = let-                 x  = hOccurs (TIP l)-                 l' = hDeleteAtProxy (toProxy x) l-                 y  = hOccurs (TIP l')-                in (x,y)+{- $sessionlog2 +Don't bother repeating the type error: --- | A specific tuple-oneTrue :: TIP (HCons Int (HCons Bool HNil))-oneTrue = hExtend (1::Int) (hExtend True emptyTIP)+>>> let doctestEq x y = x == y || "No instance for" `Data.List.isInfixOf` x +>>> Sheep .*. myTipyCow+-- type error -- -{-----------------------------------------------------------------------------}+-}
− 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,29 @@+{-# LANGUAGE OverlappingInstances #-}++{- |+   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++-}++module Data.HList.TypeEqO where++import Data.HList.FakePrelude++instance HEq x x True+instance False ~ b => HEq x y b+-- instance TypeEq x y HFalse -- would violate functional dependency+++class TupleType t (b :: Bool) | t -> b+instance TupleType () True+instance TupleType (x,y) True+instance TupleType (x,y,z) True+-- Continue for a while+instance False ~ b => TupleType x b+-- instance TupleType x HFalse -- would violate functional dependency
Data/HList/Variant.hs view
@@ -1,6 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances,-  UndecidableInstances, FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-} + {- |    The HList library @@ -22,72 +25,40 @@ module Data.HList.Variant where  import Data.HList.FakePrelude-import Data.HList.HListPrelude-import Data.HList.HArray import Data.HList.Record+import Data.HList.HList  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- | Variant types on the basis of label-maybe pairs.  newtype Variant mr = Variant mr  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- | Turn proxy sequence into sequence of Nothings -class HMaybied r r' | r -> r'- where-  hMaybied :: r -> r'--instance HMaybied HNil HNil- where-  hMaybied _ = HNil+data HMaybeF = HMaybeF+instance ((LVPair l (Proxy t) ~ a, b ~ LVPair l (Maybe t))) =>  ApplyAB HMaybeF a b   where+    applyAB _ _ = LVPair Nothing -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)+hMaybied x = hMap HMaybeF x  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- | 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---{-----------------------------------------------------------------------------}+-- it seems we can blame 'hUpdateAtLabel' (not 'HMap') for needing the asTypeOf?+mkVariant x y (Record v) = let r1 = Record (hMaybied v) in+    case hUpdateAtLabel x (Just y) r1 `asTypeOf` r1 of+    Record t -> Variant t +-- -------------------------------------------------------------------------- -- | Public destructor -unVariant :: ( 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+unVariant x (Variant v) = hLookupByLabel x (Record v)  -{-----------------------------------------------------------------------------}-+-- -------------------------------------------------------------------------- -- | Variants are opaque  instance Show (Variant v)@@ -95,4 +66,3 @@   show _ = "<Cannot show Variant content!>"  -{-----------------------------------------------------------------------------}
+ 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/Label5.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Yet another model of labels.++   This model allow us to use any type as label type.+   As a result, we need some generic instances.++   Also, type errors may be more confusing now.+-}++module Data.HList.Label5 where++import Data.Typeable+import Data.Char+import Data.HList.FakePrelude+import Data.HList.Record+++-- | Equality on labels++-- instance TypeEq x y b => HEq x y b+++-- | Show label++instance Typeable x => ShowLabel x+ where+  showLabel = (\(x:xs) -> toLower x:xs)+            . reverse+            . takeWhile (not . (==) '.')+            . reverse+            . show+{-+            . tyConString+            . typeRepTyCon+-}+            . typeOf
+ Data/HList/broken/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,306 @@+{-# 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 :: (HFind l (RecordLabels r) n,HUpdateAtHNat n (LVPair l v) r,HasField l (Record r) (Proxy v)) =>+    Label l-> v -> Record r -> Record (HUpdateAtHNatR n (LVPair l v) r)+hUnproxyLabel l v r = hUpdateAtLabel l v r+ where+  tpe :: a -> Proxy a -> ()+  tpe _ _ = ()+  _ = tpe v (hLookupByLabel l r)+++infixr 2 .^.+{-|+  This is a variation on updating, so use the same fixity as (.\@.).+-}+f@(LVPair 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 (LVPair 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 NarrowM a '[] (HJust (Record '[])) where++    narrowM _ _ = HJust emptyRecord++instance (H2ProjectByLabels (l ': '[]) a rin rout,+          NarrowM' rin rout b res)+    => NarrowM a (LVPair 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' where+    narrowM'' :: f -> r -> r'++instance (hNothing ~ HNothing) => 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 (LVPair l v ': '[]) rout+         ) => Narrow r ( LVPair 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 (RecordLabels a) (RecordLabels 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 :: 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 :: r1 -> r2 -> res+++instance (HEq r1 r2 b, RecordEquiv' b r1 r2 res)+    => RecordEquiv r1 r2 res where+    equivR _ _ = equivR' (undefined::Proxy b) (undefined::r1) (undefined::r2)+-- 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' (undefined :: Proxy False) r1p r2p+     where r1p r1 = narrowM (r1 :: Record r1) r2+           r2p r2 = narrowM (r2 :: Record r2) r1++class RecordEquiv' (b :: Bool) pj1 pj2 res | b pj1 pj2 -> res where+    equivR' :: Proxy b -> pj1 -> pj2 -> res++instance RecordEquiv' False (r1->HJust r2) (r2->HJust r1) (HJust (r1->r2,r2->r1))+    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++hNilTcName :: TyCon+hNilTcName = mkTyCon "HList.HNil"+instance Typeable HNil+ where+  typeOf _ = mkTyConApp hNilTcName []++hConsTcName :: TyCon+hConsTcName = mkTyCon "HList.HCons"+instance (Typeable x, Typeable y) => Typeable (HCons x y)+ where+  typeOf ~(HCons x y)+   = mkTyConApp hConsTcName [ typeOf x, typeOf y ]++recordTcName :: TyCon+recordTcName = mkTyCon "HList.Record"+instance Typeable x => Typeable (Record x)+ where+  typeOf ~(Record x)+   = mkTyConApp recordTcName [ typeOf x ]++hFieldTcName :: TyCon+hFieldTcName = mkTyCon "HList.F"+instance (Typeable x, Typeable y) => Typeable (LVPair x y)+ where+  typeOf _+   = mkTyConApp hFieldTcName [ typeOf (undefined::x), typeOf (undefined::y)  ]++proxyTcName :: TyCon+proxyTcName = mkTyCon "HList.Proxy"+instance Typeable x => Typeable (Proxy x)+ where+  typeOf _+   = mkTyConApp proxyTcName [ typeOf (undefined::x) ]+++-}+
+ 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/RecordP.hs view
@@ -0,0 +1,213 @@+{-# 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::[*]) vs = RecordP (HList vs)+++-- Build a record. I wonder if the 'ls' argument of mkRecordP can be+-- removed. So far, we had no need for it...++mkRecordP :: (HSameLength ls vs, HLabelSet ls) => ls -> vs -> RecordP ls vs+mkRecordP _ vs = RecordP vs++-- The contraint that two type level lists have the same length+class HSameLength l1 l2+instance HSameLength '[] '[]+instance HSameLength l1 l2 => HSameLength (e1 ': l1) (e2 ': l2)++-- Build an empty record+emptyRecordP :: RecordP ('[]) ('[])+emptyRecordP = mkRecordP HNil HNil++-- 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 (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/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/TIC.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Type-indexed co-products.++   (There are other ways: see ConsUnion.hs, for example)+-}++module Data.HList.TIC where++import Data.Dynamic++import Data.HList.HList+import Data.HList.FakePrelude+import Data.HList.HOccurs+import Data.HList.TIP+++-- --------------------------------------------------------------------------+-- | A datatype for type-indexed co-products++newtype TIC l = TIC Dynamic+++-- --------------------------------------------------------------------------+-- | Public constructor++mkTIC :: ( HTypeIndexed l+         , HTypeProxied l+         , HOccurs' (Proxy i) l+         , Typeable i+         )+      => i -> TIC l++mkTIC i = TIC (toDyn i)+++-- --------------------------------------------------------------------------+-- | Public destructor++unTIC :: ( HTypeIndexed l+         , HTypeProxied l+         , HOccurs' (Proxy o) l+         , Typeable o+         )+      => TIC l -> Maybe o++unTIC (TIC i) = fromDynamic i+++-- --------------------------------------------------------------------------+-- | 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)+++-- --------------------------------------------------------------------------+-- | TICs are opaque++instance Show (TIC l)+ where+  show _ = "<Cannot show TIC content!>"+
+ 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,104 @@ Name:                HList-Version:             0.2.3+Version:             0.3.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.+                     .+                     User code should import "Data.HList" or+                     "Data.HList.CommonMain" for a slightly more limited scope 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.8+Tested-With:         GHC==7.6.2, GHC==7.7 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/*.hs,+                     examples/broken/*.hs,+                     examples/broken/*.lhs, -extensions:          EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,-                     MultiParamTypeClasses, OverlappingInstances, ScopedTypeVariables, RankNTypes,-                     ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances-ghc-options:         -Wall+                     examples/*.ref,+                     examples/*.out,++                     examples/broken/*.ref,+                     examples/broken/*.out,++                     Data/HList/broken/*.hs,+                     Data/HList/obsolete/*.hs,++                     examples/Main.in++Source-Repository head+    type: darcs+    location: http://code.haskell.org/HList++++library+  Build-Depends:       base >= 4 && < 5, template-haskell, ghc-prim,+                       mtl+  Exposed-modules:     Data.HList,++                       Data.HList.CommonMain,+                       Data.HList.Data,+                       Data.HList.FakePrelude,+                       Data.HList.FakePrelude.Proxy,+                       Data.HList.HArray,+                       Data.HList.HList,+                       Data.HList.HListPrelude,+                       Data.HList.HOccurs,+                       Data.HList.HTypeIndexed,+                       Data.HList.HZip,+                       Data.HList.Keyword,+                       Data.HList.Label3,+                       Data.HList.Label6,+                       Data.HList.Labelable,+                       Data.HList.MakeLabels,+                       Data.HList.Record,+                       Data.HList.RecordPuns,+                       Data.HList.TIC,+                       Data.HList.TIP,+                       Data.HList.TypeEqO,+                       Data.HList.Variant+++  Ghc-Options:         -Wall -fno-warn-missing-signatures++  Extensions:          ConstraintKinds+                       DataKinds+                       EmptyDataDecls+                       FlexibleContexts+                       FlexibleInstances+                       FunctionalDependencies+                       GADTs+                       KindSignatures+                       MultiParamTypeClasses+                       PolyKinds+                       RankNTypes,+                       ScopedTypeVariables+                       TypeFamilies+                       TypeOperators+                       UndecidableInstances++  if impl(ghc >= 7.7)+    Extensions:        AllowAmbiguousTypes+                       StandaloneDeriving++Test-Suite examples+  Type:     exitcode-stdio-1.0+  Ghc-Options: -threaded+  Main-Is: examples/runexamples.hs+  Build-Depends: base, hspec == 1.7.*, directory, filepath, process, syb, cmdargs,+                    lens++Test-Suite doctests+  Type:     exitcode-stdio-1.0+  Ghc-Options: -threaded+  Main-Is: examples/rundoctests.hs+  Build-Depends: base, doctest >= 0.8
README view
@@ -26,7 +26,10 @@  ---------------------------------------------------------------------- -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,@@ -34,14 +37,17 @@  You can get HList from Hackage or from Darcs: +$ cabal update && cabal install HList++Or:+ $ darcs get --partial http://code.haskell.org/HList/+$ cd HList; cabal install  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+for GHC-7.6 and GHC-7.7. Older compilers are not supported. -One may run "cd examples; make test" to check the distribution.+One may run "cabal test" to check the distribution.  See ChangeLog for updates.
+ examples/Datatypes1.hs view
@@ -0,0 +1,14 @@+module Datatypes1 where++-- The fout-n-mouth example++newtype Key     = Key Integer+                deriving (Show,Eq,Ord)+newtype Name   = Name String+                deriving (Show,Eq)+data Breed     = Cow | Sheep+                deriving (Show,Eq)+newtype Price  = Price Float+                deriving (Show,Eq,Ord)+data Disease   = BSE | FM+                deriving (Show,Eq)
+ examples/Datatypes2.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Datatypes2 where++import Data.Typeable++-- The fout-n-mouth example+-- (deriving Typeable only supported for GHC)++newtype Key     = Key Integer+                deriving (Show,Eq,Ord,Typeable)+newtype Name   = Name String+                deriving (Show,Eq,Typeable)+data Breed     = Cow | Sheep+                deriving (Show,Eq,Typeable)+newtype Price  = Price Float+                deriving (Show,Eq,Ord,Typeable)+data Disease   = BSE | FM+                deriving (Show,Eq,Typeable)
+ examples/FooBar.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS -fglasgow-exts #-}+{-# OPTIONS -fallow-undecidable-instances #-}+{-# OPTIONS -fallow-overlapping-instances #-}++data Foo x y+class Bar x y | x -> y+class Zoo x y | x -> y++{-++Works for both GHC and Hugs++instance Bar (Foo x y) y+instance Bar (Foo (Foo x y) z) z++-}++{-++Works for GHC but not Hugs++-}++instance Zoo x r => Bar (Foo x y) r+instance Zoo x r => Bar (Foo (Foo x y) z) r++
+ examples/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/Main.in view
@@ -0,0 +1,1 @@+main
+ examples/MainGhcGeneric1.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverlappingInstances#-}+{-# LANGUAGE UndecidableInstances#-}+{-# LANGUAGE ScopedTypeVariables #-}++{-++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   This is a main module for exercising a model with generic type+   cast and generic type equality. Because of generic type equality,+   this model works with GHC but it does not work with Hugs.++   Note: even though there are no overlapping instances in *this*+   module, one must still enable overlapping instances here; otherwise+   overlapping (for type equality) is not resolved properly for the+   imported modules.++-}++module MainGhcGeneric1 (++{-+ module Datatypes2,+ module Data.HList.CommonMain,+ module Data.HList.TypeEqO,+ module Data.HList.Label3,+-- mainExport+-}++) where++import Datatypes2+import Data.HList.CommonMain -- hiding (HDeleteMany, hDeleteMany)++{-+import Data.HList.RecordAdv+import Data.HList.RecordP+-}+++-- --------------------------------------------------------------------------++type Animal =  '[Key,Name,Breed,Price]++angus :: HList Animal+angus =  HCons (Key 42)+           (HCons (Name "Angus")+           (HCons  Cow+           (HCons (Price 75.5)+            HNil)))++tList1 = hFoldr (HSeq HPrint) (return () :: IO ()) angus+{-+ Key 42+ Name "Angus"+ Cow+ Price 75.5+-}++tList2 = print $ hAppend angus angus+{-+H[Key 42, Name "Angus", Cow, Price 75.5, Key 42, Name "Angus", Cow, Price 75.5]+-}+++testListBasic = do+  putStrLn "\nBasic HList tests"+  tList1+  tList2++testHArray = do+  putStrLn "\ntestHArray"+  myProj1+  myProj2+  myProj2'+  myProj3+  myProj4++myProj1 = print $ hProjectByHNats (hNats (HCons hZero (HCons hZero HNil))) angus+-- H[Key 42]++-- Before:+-- H[Key 42, Key 42]+-- XXX I don't duplicate at present!++myProj2 = print $ +	  hProjectByHNats (hNats (HCons hZero (HCons (hSucc hZero) HNil))) angus+-- H[Key 42, Name "Angus"]++myProj2' = print $ +	  hProjectByHNats (undefined::Proxy ['HZero, 'HSucc 'HZero]) angus+-- H[Key 42, Name "Angus"]++myProj3 = print $ +	  hProjectAwayByHNats (hNats (HCons hZero HNil)) angus+-- H[Name "Angus", Cow, Price 75.5]++myProj4 = print $ +	  hSplitByHNats +	    (undefined::Proxy ['HZero, 'HSucc 'HZero])+	    angus+-- (H[Key 42, Name "Angus"],H[Cow, Price 75.5])++testHOccurs = do+  putStrLn "\ntestHOccurs"+  print (hOccurs angus :: Breed)+  print $ hOccurs (TIP (HCons 1 HNil))+  print $ null $ hOccurs (TIP (HCons [] HNil))+  print (hProject angus :: HList '[Key, Name])+++testTypeIndexed = do+  putStrLn "\ntestTypeIndexed"+  print typeIdx1+  print typeIdx2+  print $ hUpdateAt Sheep typeIdx1+  print $ hDeleteAt (undefined::Proxy Breed) typeIdx2+  print $ hProjectBy (undefined::Proxy '[Breed]) angus+  print $ hSplitBy (undefined:: Proxy '[Breed]) angus+ where +  typeIdx1 = hDeleteMany (undefined::Proxy Name) angus+  typeIdx2 = BSE .*. angus++-- |+-- This example from the TIR paper challenges singleton lists.+-- Thanks to the HW 2004 reviewer who pointed out the value of this example.+-- We note that the explicit type below is richer than the inferred type.+-- This richer type is needed for making this operation more polymorphic.+-- That is, /a)/ would not work without the explicit type, +-- while /b/ would:+--+-- >  a)  ((+) (1::Int)) $ snd $ tuple oneTrue+-- >  b)  ((+) (1::Int)) $ fst $ tuple oneTrue++tuple :: forall e1 e2 n l n2.+    (HDeleteAtHNat n l,+     HOccurs e1 (TIP l),+     HOccurs e2 (TIP (HDeleteAtHNatR n l)),+     HType2HNat e1 l n,+     -- extra, not inferred+     HType2HNat e2 l n2,+     HOccurs e1 (TIP (HDeleteAtHNatR n2 l))+    ) => TIP l -> (e1,e2)+tuple (TIP l) = let+                 x  = hOccurs (TIP l)+                 l' = hDeleteAt (undefined::Proxy e1) l+                 y  = hOccurs (TIP l')+                in (x,y)++-- | A specific tuple+-- Need to import an instance of TypeEq to be able to run the examples+oneTrue :: TIP '[Int, Bool]		-- inferred+oneTrue = (1::Int) .*. True .*. emptyTIP++testTuple = do+  putStrLn "\ntestTuple"+  print $ let (a,b) = tuple oneTrue in (a+(1::Int), not b)+  print $ let b = not $ fst $ tuple oneTrue in (1::Int,b)+  print $ tuple oneTrue == (1::Int,True)+  print $ ((+) (1::Int)) $ fst $ tuple oneTrue+  -- requires explicit type for tuple+  print $ ((+) (1::Int)) $ snd $ tuple oneTrue+++myTipyCow = TIP angus++animalKey :: ( SubType l (TIP Animal) -- explicit+             , HOccurs Key l          -- implicit+             ) => l -> Key+animalKey = hOccurs++animalish :: SubType l (TIP Animal) => l -> l+animalish = id+animalKey' l = hOccurs (animalish l) :: Key++testTIP = do+  putStrLn "\ntestTIP"+  print $ (hOccurs myTipyCow :: Breed)+  print $ BSE .*. myTipyCow+  -- print $ hExtend Sheep $ myTipyCow+  {- if we uncomment the line above, we get the type error+     about the violation of the TIP condition: Breed type+     occurs twice.++    No instance for (Fail * (TypeFound Breed))+      arising from a use of `hExtend'+  -}+  print $ Sheep .*. tipyDelete (undefined::Proxy Breed) myTipyCow+  print $ tipyUpdate Sheep myTipyCow++{-+data MyNS = MyNS -- a name space for record labels++key   = firstLabel MyNS  (undefined::DKey)+name  = nextLabel  key   (undefined::DName)+breed = nextLabel  name  (undefined::DBreed)+price = nextLabel  breed (undefined::DPrice)++data DKey;   instance Show DKey   where show _ = "key"+data DName;  instance Show DName  where show _ = "name"+data DBreed; instance Show DBreed where show _ = "breed"+data DPrice; instance Show DPrice where show _ = "price"++-}++makeLabels3 "MyNS" (words "key name breed price")++unpricedAngus =  key    .=. (42::Integer)+             .*. name   .=. "Angus"+             .*. breed  .=. Cow+             .*. emptyRecord+++getKey l = hLookupByLabel key l++testRecords = do+  putStrLn "\ntestRecords"+  print $ unpricedAngus+  print $ unpricedAngus .!. breed+  print $ test3+  print $ test4+  print $ test5+  print $ hProjectByLabels (hLabels (breed `HCons` price `HCons` HNil)) test5+ where+  test3 = hDeleteAtLabel breed unpricedAngus+  test4 = breed .=. Sheep .@. unpricedAngus+  test5 = price .=. 8.8 .*. unpricedAngus+  -- test7 should have the same type as unpricedAngus and test4 but+  -- with the different order of labels+  test7 = (newLVPair breed Sheep) .*. test3++{-+testRecords =   ( test1 +              , ( test2+              , ( test3 +              , ( test4+              , ( test5+              , ( test6+	      , (test7, test81, test82, test83, test84, test85)+                ))))))+ where+  test81 = equivR test1 test3 -- HNothing+  test82 = let HJust (r17,r71) = equivR test1 test7 in (r17 test1,r71 test7)+  test83 = let HJust (r17,r71) = +		   equivR test1 test7 in show (r17 test1) == show test7+  test84 = let HJust (r47,r74) = +		   equivR test4 test7 in (show (r47 test4) == show test7,+					  show (r74 test7) == show test4)+  test85 = let HJust (r7,r7') = +		   equivR test7 test7 in show (r7 test7) == show (r7' test7)++testRecordsP =   ( test1 +		 , ( test2+		 , ( test3 +		 , ( test4+		 , ( test5+		 , ( test6+                   ))))))+ where+--  test1 = mkRecordP (undefined::Animal) angus+  test1 = record_r2p unpricedAngus+  test2 = test1 .!. breed+  test3 = hDeleteAtLabelP breed test1+--  test4 = test1 .@. breed .=. Sheep+  test4 = hExtend (newLVPair breed Sheep) test3+  test5 = price .=. 8.8 .*. test1+  test6 = fst $ h2projectByLabels (HCons breed (HCons price HNil)) test5+++-}++type AnimalCol = [Key,Name,Breed,Price]++testTIC = do+  putStrLn "\ntestTIC"+  print $ myCol+  print $ (unTIC myCol :: Maybe Breed)+  print $ (unTIC myCol :: Maybe Price)+ where+  myCol = mkTIC Cow :: TIC AnimalCol++{-++myCol = mkTIC Cow :: TIC AnimalCol++*TIC> unTIC myCol :: Maybe Breed+Just Cow+*TIC> unTIC myCol :: Maybe Price+Nothing+*TIC> mkTIC "42" :: TIC AnimalCol+Type error ...+*TIC> unTIC myCol :: Maybe String+Type error ...++-}++testVariant = (testVar1,(testVar2,(testVar3)))+ where+  animalVar =  key   .=. (proxy::Proxy Integer)+           .*. name  .=. (proxy::Proxy String)+           .*. breed .=. (proxy::Proxy Breed)+           .*. emptyRecord+  testVar1 = mkVariant name "angus" animalVar+  testVar2 = unVariant key testVar1+  testVar3 = unVariant name testVar1++{-+-- --------------------------------------------------------------------------++main = mainExport+mainExport+   = print $   ( testHArray+               , ( testHOccurs+               , ( testTypeIndexed+               , ( testTuple+               , ( testTIP++               , ( testRecords+               , ( testRecordsP+               , ( testTIC+               , ( testVariant+               )))))))))++-}++main = do+       testListBasic+       testHArray+       testHOccurs+       testTypeIndexed+       testTuple+       testTIP+       testRecords+       testTIC
+ examples/MainGhcGeneric1.out view
@@ -0,0 +1,54 @@++Basic HList tests+Key 42+Name "Angus"+Cow+Price 75.5+H[Key 42, Name "Angus", Cow, Price 75.5, Key 42, Name "Angus", Cow, Price 75.5]++testHArray+H[Key 42]+H[Key 42, Name "Angus"]+H[Key 42, Name "Angus"]+H[Name "Angus", Cow, Price 75.5]+(H[Key 42, Name "Angus"],H[Cow, Price 75.5])++testHOccurs+Cow+1+True+H[Key 42, Name "Angus"]++testTypeIndexed+H[Key 42, Cow, Price 75.5]+H[BSE, Key 42, Name "Angus", Cow, Price 75.5]+H[Key 42, Sheep, Price 75.5]+H[BSE, Key 42, Name "Angus", Price 75.5]+H[Cow]+(H[Cow],H[Key 42, Name "Angus", Price 75.5])++testTuple+(2,False)+(1,False)+True+2+2++testTIP+Cow+TIPH[BSE, Key 42, Name "Angus", Cow, Price 75.5]+TIPH[Sheep, Key 42, Name "Angus", Price 75.5]+TIPH[Key 42, Name "Angus", Sheep, Price 75.5]++testRecords+Record{key=42,name="Angus",breed=Cow}+Cow+Record{key=42,name="Angus"}+Record{key=42,name="Angus",breed=Sheep}+Record{price=8.8,key=42,name="Angus",breed=Cow}+Record{price=8.8,breed=Cow}++testTIC+<Cannot show TIC content!>+Just Cow+Nothing
+ examples/MainGhcGeneric1.ref view
@@ -0,0 +1,54 @@++Basic HList tests+Key 42+Name "Angus"+Cow+Price 75.5+H[Key 42, Name "Angus", Cow, Price 75.5, Key 42, Name "Angus", Cow, Price 75.5]++testHArray+H[Key 42]+H[Key 42, Name "Angus"]+H[Key 42, Name "Angus"]+H[Name "Angus", Cow, Price 75.5]+(H[Key 42, Name "Angus"],H[Cow, Price 75.5])++testHOccurs+Cow+1+True+H[Key 42, Name "Angus"]++testTypeIndexed+H[Key 42, Cow, Price 75.5]+H[BSE, Key 42, Name "Angus", Cow, Price 75.5]+H[Key 42, Sheep, Price 75.5]+H[BSE, Key 42, Name "Angus", Price 75.5]+H[Cow]+(H[Cow],H[Key 42, Name "Angus", Price 75.5])++testTuple+(2,False)+(1,False)+True+2+2++testTIP+Cow+TIPH[BSE, Key 42, Name "Angus", Cow, Price 75.5]+TIPH[Sheep, Key 42, Name "Angus", Price 75.5]+TIPH[Key 42, Name "Angus", Sheep, Price 75.5]++testRecords+Record{key=42,name="Angus",breed=Cow}+Cow+Record{key=42,name="Angus"}+Record{key=42,name="Angus",breed=Sheep}+Record{price=8.8,key=42,name="Angus",breed=Cow}+Record{price=8.8,breed=Cow}++testTIC+<Cannot show TIC content!>+Just Cow+Nothing
+ examples/MainGhcGeneric2.hs view
@@ -0,0 +1,22 @@+{-++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Included for completeness' sake.+   The TypeEqBoolGeneric2.hs implementation is demonstrated.++-}++module MainGhcGeneric2 where++import Data.HList+++{-----------------------------------------------------------------------------}++main = print ( hEq True False+             , hEq True "True"+             )+++{-----------------------------------------------------------------------------}
+ examples/MainGhcGeneric2.out view
@@ -0,0 +1,1 @@+(HTrue,HFalse)
+ examples/MainGhcGeneric2.ref view
@@ -0,0 +1,1 @@+(HTrue,HFalse)
+ examples/MainPatternMatch.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE PatternGuards #-}++-- Pattern-matching on HList's Records++{-+  See the thread `Re: (small) records proposal for Haskell '06'+  Haskell mailing list, January 2006+  http://www.haskell.org/pipermail/haskell/2006-January/017276.html++Joel Reymont wrote:+> How does pattern matching work with HList?+> I would like to pass a HList to a function and only match if a+> certain field had a certain value.++The code below defines the function foo that accepts a record and+yields one value if the field PtX of the record has the value 0. If+the field has any other value, a different result is returned. The+function is written in a pattern-matching style. Also, the function is+record-polymorphic: it takes _any_ record (of any `record type') that+happens to have the field names PtX.++        *Test> :t foo+        foo :: (Num v, HasField (Proxy PtX) r v) => r -> [Char]++-}++module Main where++import Data.HList++makeLabels ["px","py"]++-- Labels+-- The more convenient labels, Label4.hs, need -fallow-overlapping-instances+-- The less convenient label representation needs fewer extensions.+-- We go for more convenient...++{-+data PtX; px = proxy::Proxy PtX+data PtY; py = proxy::Proxy PtY+-}+++accessor r f = r # f++-- 1D points+point1 x = +       px .=. x+   .*. emptyRecord++-- 2D points+point2 x y = +       px .=. x+   .*. py .=. (y + 10)+   .*. emptyRecord+++-- Record-polymorphic function, which illustrates record pattern-matching,+-- with the help of generalized guards+foo p | 0 <- p # px = "X is zero"+foo _ = "something else"++test1  = foo (point1 0)     -- X is zero+test1' = foo (point1 42)    -- something else+test2 = foo (point2 10 20)  -- something else+-- inline construction of the record+test3 = foo (py .=. False .*. px .=. 0 .*. emptyRecord) -- X is zero++main = do+       putStrLn test1+       putStrLn test1'+       putStrLn test2+       putStrLn test3
+ examples/MainPatternMatch.out view
@@ -0,0 +1,4 @@+X is zero+something else+something else+X is zero
+ examples/MainPatternMatch.ref view
@@ -0,0 +1,4 @@+X is zero+something else+something else+X is zero
+ examples/MainPosting-040607.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-++Hi Mike,++You might find heterogeneous lists useful.+http://www.cwi.nl/~ralf/HList/+See the treatment of your example below.++Cheers,+Ralf++-}++module Main where++import Data.HList++-- These are your two "implementations".++data MyImplementation1 = MyImplementation1 Int deriving (Show,Eq,Typeable)+data MyImplementation2 = MyImplementation2 Int deriving (Show,Eq,Typeable)+++-- This is your interface class and the two instances.++class MyInterface a + where+  foo :: a -> Int++instance MyInterface MyImplementation1+ where+  foo (MyImplementation1 i) = i++instance MyInterface MyImplementation2+ where+  foo (MyImplementation2 i) = i+++-- Here is your list,+-- without the noise you don't like.++list1 =  MyImplementation1 10+     .*. MyImplementation2 20+     .*. HNil+++-- If you like, this is the type, but it is not needed.+-- This list is not opaque. Less trouble in our experience.+-- (When compared to using existentials.)++type MyList = HList '[MyImplementation1, MyImplementation2]+++-- Perhaps you want to make sure that you have a list of implementations+-- of MyInterface. Here is *one* way to do it. But you don't need to do it+-- because this will be automatically checked (statically) whenever you+-- try to use the fooISH interface.++class ListOfMyInterface l+ where+  listOfMyInterface :: HList l -> HList l+  listOfMyInterface = id++instance ListOfMyInterface '[]+instance ( MyInterface e+         , ListOfMyInterface l+         )+      =>   ListOfMyInterface (e ': l)+++-- So you apply the id function with the side effect of statically +-- ensuring that you are given a list of implementations of MyInterface.++list2 :: MyList+list2 = listOfMyInterface list1+++-- Here is another way to do it.+-- You apply a heterogenous fold to the list.+-- This second solution is just for fun.++data ImplementsMyInterface = ImplementsMyInterface++instance (+ x ~ (e,HList l),+ y ~ (HList (e ': l))+ ) => ApplyAB ImplementsMyInterface x y+ where+  applyAB _ (e,l) = HCons e l++myKindOfList l = hFoldr ImplementsMyInterface HNil l+++-- Basically again you apply the identity function; a deep one this time.++list3 :: MyList+list3 = myKindOfList list1+++-- Your equality can indeed not work because the existentially quantified+-- implementations are of course opaque. You cannot compare apples and+-- oranges. Equality of heterogeneous lists is trivial; it is just derived.+-- To make it a little bit more interesting, we can consider heterogeneous+-- or stanamic equality. So you will always get a Boolean even for lists+-- of different types. See below.+++-- Here is your bar function.+-- It uses one sort of maps on heterogeneous lists.++bar :: MyList -> Int+bar = sum . hMapOut Foo++data Foo = Foo -- type driver for class-level application++instance (MyInterface e, int ~ Int) => ApplyAB Foo e int+ where+  applyAB _ e = foo e+++-- Yet another heterogeneous equality.+-- Just for fun.+--+yaHEq :: (Typeable a, Typeable b, Eq a) => a -> b -> Bool+yaHEq a b = case cast b of+             Just a' -> a == a'+             Nothing -> False++-- Yet another heterogeneous list; a bit less typed.+data AnyMyInterface = forall a. ( Eq a+                                , Typeable a+                                , MyInterface a+                                ) => AnyMyInterface a++type MyList' = [AnyMyInterface]+list4 = [ AnyMyInterface $ MyImplementation1 10+        , AnyMyInterface $ MyImplementation1 10+        ]+list5 = [ AnyMyInterface $ MyImplementation1 10+        , AnyMyInterface $ MyImplementation2 10+        ]+list6 = [ AnyMyInterface $ MyImplementation1 10+        , AnyMyInterface $ MyImplementation2 20+        ]++instance Eq AnyMyInterface+ where+  (AnyMyInterface x) == (AnyMyInterface y) = x `yaHEq` y+++{-++Demo follows.++*Main> :l gh-users-040607.hs+Compiling FakePrelude      ( ./FakePrelude.hs, interpreted )+Compiling HType            ( HType.hs, interpreted )+Compiling HList            ( ./HList.hs, interpreted )+Compiling HArray           ( ./HArray.hs, interpreted )+Compiling HTypeDriven      ( ./HTypeDriven.hs, interpreted )+Compiling Main             ( gh-users-040607.hs, interpreted )+Ok, modules loaded: Main, HTypeDriven, HArray, HList, HType, FakePrelude.+*Main> list1+HCons (MyImplementation1 10) (HCons (MyImplementation2 20) HNil)+*Main> bar list1+30+*Main> list1 == list1+True+*Main> list1 `hStagedEq` hReverse list1+False+*Main> list4!!0 == list4!!1+True+*Main> list5!!0 == list5!!1+False+*Main> list6!!0 == list6!!1+False++-}++main = print+             ( list1+           , ( list1 == list1+          --  , ( list1 `hStagedEq` hReverse list1+           , ( list4!!0 == list4!!1+           , ( list5!!0 == list5!!1+           , ( list6!!0 == list6!!1+           )))))++{-++Mike Aizatsky wrote:++>Hello,+>+>I'm in process of rewriting the old Java application. While this is for sure+>lots of fun, there're some problems in modeling the java interfaces.+>+>Here's the common Java scenario (it's actually the pattern, common for all+>OO-languages, so there should be no problems in understanding it):+>+>interface MyInterface {+>	int foo();+>}+>+>class MyImplementation1 implements MyInterface { int foo() {...} }+>class MyImplementation2 implements MyInterface { int foo() {...} }+>+>And, somewhere in the code:+>+>int bar(List<MyInterface> list) { .... sum up all foos & return .... }+>+>I've found quite an obvious translation of it to Haskell:+>+>module Ex where+>+>class MyInterface a where+>	foo :: a -> Int+>+>data AnyMyInterface = forall a. (MyInterface a) => AnyMyInterface a+>+>instance MyInterface AnyMyInterface where+>	foo (AnyMyInterface a) = foo a+>+>+>data MyImplementation1 = MyImplementation1 Int+>+>instance MyInterface MyImplementation1 where+>	foo(MyImplementation1 i) = i+>+>data MyImplementation2 = MyImplementation2 Int+>+>instance MyInterface MyImplementation2 where+>	foo(MyImplementation2 i) = i+>+>+>type MyList = [AnyMyInterface]+>+>list1 :: MyList+>list1 = [AnyMyInterface (MyImplementation1 10), AnyMyInterface+>(MyImplementation2 20)]+>+>bar :: MyList -> Int+>bar l = sum (map foo l)+>+>+>However there're some problems with this way to go:+>+>1. It's quite verbose. I already have a dozen of such interfaces, and I'm a+>bit tired of writing all this AnyInterface stuff. I'm already thinking about+>writing the Template Haskell code to generate it. Is anything similar+>available around?+>+>2. I don't like the fact that I need to wrap all implementations inside the+>AnyMyInterface when returning values (see list1). Any way to get rid of it?+>+>3. The big problem. I can't make AnyMyInterface to be an instance of Eq. I+>write:+>+>data AnyMyInterface = forall a. (MyInterface a, Eq a) => AnyMyInterface a+>instance Eq AnyMyInterface where+>	(==) (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2+>+>And it gives me an error (ghc 6.2.1):+>+>    Inferred type is less polymorphic than expected+>        Quantified type variable `a1' is unified with another quantified+>type variable `a'+>    When checking an existential match that binds+>        a1 :: a+>        a2 :: a1+>    The pattern(s) have type(s): AnyMyInterface+>                                 AnyMyInterface+>    The body has type: Bool+>    In the definition of `==':+>        == (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2+>    In the definition for method `=='+>+>Honestly, I don't understand what's going on. My guess is that the problem+>comes from the fact that a1 & a2 might be of different Implementations. Is+>it right? Any way to define the Eq instance of AnyMyInterface?+>+>+>So, it looks like that existential data types do allow you to mimic the+>polymorphic data structures, found in OO languages. But it results in much+>more verbose code. Are there any other ways to do the same stuff?+>+>_______________________________________________+>Glasgow-haskell-users mailing list+>Glasgow-haskell-users@haskell.org+>http://www.haskell.org/mailman/listinfo/glasgow-haskell-users+>++-}
+ examples/MainPosting-040607.out view
@@ -0,0 +1,1 @@+(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False))))
+ examples/MainPosting-040607.ref view
@@ -0,0 +1,1 @@+(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False))))
+ examples/MainPosting-051106.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Main where++-- Needed for a reply to the Haskell mailing list++import Data.HList.CommonMain hiding (Comp(..))++main = do+    print $ comp "abc"+    print $ (hComposeList test2 "abc" :: Int) -- definition in HList now++test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil))+test2 = length .*. (+1) .*. (*2) .*. HNil++data Comp++{- simpler class. wouldn't work with test2. The original HFoldr won't work with+ - Apply anymore.+instance Apply Comp (x -> y,y -> z)+ where+  type ApplyR Comp (x -> y,y -> z) = x -> z+  apply _ (f,g) = g . f+  -}++instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz)+    => ApplyAB Comp xyz xz+ where+  applyAB _ (f,g) = g . f++-- Function composition based on type code works.++comp  = hFoldr (undefined::Comp) (id::Int -> Int) test++-- Function composition based on normal polymorphism doesn't+-- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++{-++From Ralf.Lammel at microsoft.com  Mon Nov  7 00:11:01 2005+From: Ralf.Lammel at microsoft.com (Ralf Lammel)+Date: Sun Nov  6 23:50:27 2005+Subject: [Haskell-cafe] Type classes and hFoldr from HList+Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com>++Hi Greg,++Since hfoldr is right-associative, I prefer to reorder your list of+functions as follows:++> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons+((*2)::(Int->Int)) HNil))++Note that I also annotated length with its specific type.+(If you really wanted to leave things more polymorphic, you would need+to engage in TypeCast.)++Providing a specific Apply instance for (.) is not necessary, strictly+necessary. We could try to exploit the normal function instance for+Apply.++Let me recall that one here for convenience:++>instance Apply (x -> y) x y+> where+>  apply f x = f x++Let me also recall the hFoldr instances:++>class HList l => HFoldr f v l r | f v l -> r+> where+>  hFoldr :: f -> v -> l -> r++>instance HFoldr f v HNil v+> where+>  hFoldr _ v _ = v++>instance ( HFoldr f v l r+>         , Apply f (e,r) r'+>         )+>      => HFoldr f v (HCons e l) r'+> where+>  hFoldr f v (HCons e l) = apply f (e,hFoldr f v l)+++To fit in (.), we would flip and uncurry it.+So we could try:++comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test++This wouldn't work.+The trouble is the required polymorphism of the first argument of+hFoldr.+The type of that argument as such is polymorphic.+However, this polymorphism does not survive type class parameterization.+You see this by looking at the HCons instance of HFoldr.+The different occurrences of "f" would need to be used at different+types.+This would only work if the type class parameter f were instantiated by+the polymorphic type of (uncurry (flip (.))). (And even then we may need+something like TypeCast.)++What you can do is define a dedicated *type code* for composition.++comp  = hFoldr (undefined::Comp) (id::Int -> Int) test++data Comp++instance Apply Comp (x -> y,y -> z) (x -> z)+ where+  apply _ (f,g) = g . f+++Ralf+++> -----Original Message-----+> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe-+> bounces@haskell.org] On Behalf Of Greg Buchholz+> Sent: Sunday, November 06, 2005 7:01 PM+> To: haskell-cafe@haskell.org+> Subject: [Haskell-cafe] Type classes and hFoldr from HList+> +> +>   I was playing around with the HList library from the paper...+> +>     Strongly typed heterogeneous collections+>     http://homepages.cwi.nl/~ralf/HList/+> +> ...and I thought I'd try to fold the composition function (.) through+a+> heterogeneous list of functions, using hFoldr...+> +> >{-# OPTIONS -fglasgow-exts #-}+> >{-# OPTIONS -fallow-undecidable-instances #-}+> >+> >import CommonMain+> >+> >main = print $ comp "abc"+> >+> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons+length+> HNil))+> >+> >comp = hFoldr (.) id test+> >+> >instance Apply (a -> b -> c -> d) (a, b) (c -> d)+> >    where+> >        apply f (a,b) = f a b+> +> ...but it fails with the following type error...+> +> ]Compiling Main             ( compose.hs, interpreted )+> ]+> ]compose.hs:10:7:+> ]    No instances for (Apply ((b -> c) -> (a -> b) -> a -> c)+> ]                            (Int -> Int, r)+> ]                            ([Char] -> a3),+> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) (Int ->+Int,+> r1) r,+> ]                      Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] ->+> Int, a1 ->a1) r1)+> ]      arising from use of `hFoldr' at compose.hs:10:7-12+> ]    Probable fix:+> ]      add an instance declaration for (Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ]                                             (Int -> Int, r)+> ]                                             ([Char] -> a3),+> ]                                       Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ](Int -> Int, r1) r,+> ]                                       Apply ((b -> c) -> (a -> b) ->+a -+> > c)+> ]([a2] -> Int, a1 -> a1) r1)+> ]    In the definition of `comp': comp = hFoldr (.) id test+> +> ...Anyway, I couldn't quite tell whether I was using hFoldr+incorrectly,+> or if I needed to have more constraints placed on the construction of+> "test", or if needed some sort of type-level function that resolves...+> +> Apply ((b -> c) -> (a -> b) -> a -> c)+> +> ...into (a -> c), or something else altogether.  I figured someone+might+> be able to help point me in the right direction.++-}
+ examples/MainPosting-051106.out view
@@ -0,0 +1,2 @@+8+8
+ examples/MainPosting-051106.ref view
@@ -0,0 +1,2 @@+8
+8
+ examples/TIPTransform.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}++-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- +-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.++module TIPTransform where++import Data.HList++-- We start with the examples++newtype MyVal = MyVal Int deriving Show++-- A sample TIP+tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP+-- TIP (HCons (MyVal 20) (HCons 1 (HCons True HNil)))++-- Update the Int component of tip1 to 2. The Int component must+-- exist. Otherwise, it is a type error+tip2 = ttip (2::Int) tip1+-- TIP (HCons (MyVal 20) (HCons 2 (HCons True HNil)))++-- Negate the boolean component of tip1+tip3 = ttip not tip1+-- TIP (HCons (MyVal 20) (HCons 1 (HCons False HNil)))++-- Update the Int component from the values of two other components+tip4 = ttip (\(MyVal x) y -> x+y) tip1+-- TIP (HCons (MyVal 20) (HCons 21 (HCons True HNil)))++-- Update the MyVal component from the values of three other components+tip5 = ttip (\b (MyVal x) y -> MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True HNil)))++-- The same but with the permuted argument order.+-- The order of arguments is immaterial: the values will be looked up using+-- their types+tip5' = ttip (\b y (MyVal x)-> MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True HNil)))++-- The implementation++class TransTIP op db where+    ttip :: op -> db -> db++instance (HMember op db b, TransTIP' b op (TIP db)) +    => TransTIP op (TIP db) where+    ttip = ttip' (proxy ::Proxy b)++class TransTIP' (b :: Bool) op db where+    ttip' :: Proxy b -> op -> db -> db++-- If op is found in a TIP, update the TIP with op+instance (HTypeIndexed db, HUpdateAtHNat n op db, HUpdateAtHNatR n op db ~ db, HType2HNat op db n)+    => TransTIP' True op (TIP db) where+    ttip' _ = tipyUpdate++-- If op is not found in a TIP, it must be a function. Look up+-- its argument in a TIP and recur.+instance (HOccurs arg db, TransTIP op db) +    => TransTIP' False (arg -> op) db where+    ttip' _ f db = ttip (f (hOccurs db)) db+++main = mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4,+		       show tip5, show tip5']
+ examples/TIPTransform.out view
@@ -0,0 +1,6 @@+TIPH[MyVal 20, 1, True]+TIPH[MyVal 20, 2, True]+TIPH[MyVal 20, 1, False]+TIPH[MyVal 20, 21, True]+TIPH[MyVal 21, 1, True]+TIPH[MyVal 21, 1, True]
+ examples/TIPTransform.ref view
@@ -0,0 +1,6 @@+TIPH[MyVal 20, 1, True]+TIPH[MyVal 20, 2, True]+TIPH[MyVal 20, 1, False]+TIPH[MyVal 20, 21, True]+TIPH[MyVal 21, 1, True]+TIPH[MyVal 21, 1, True]
+ examples/TIPTransformM.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}  -- !TF+-- Transforming a TIP: applying to a TIP a (polyvariadic) function+-- that takes arguments from a TIP and updates the TIP with the result.+-- The monadic version.+-- This file contains two versions of the code.+-- The comments -- !Simple and -- !TF distinguish the versions+--+-- In more detail: we have a typed-indexed collection TIP and we+-- would like to apply a transformation function to it, whose argument+-- types and the result type are all in the TIP. The function should locate+-- its arguments based on their types, and update the TIP+-- with the result. The function may have any number of arguments,+-- including zero; the order of arguments should not matter.++-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html+-- The problem is an interesting variation of the keyword argument problem.+-- In March 2010, Andrew Frank extended the problem for monadic operations.+-- This is the monadic version of TIPTransform.hs in the present directory.+++module TIPTransformM where++import Data.HList+import Control.Monad.Identity++-- We start with the examples++newtype MyVal = MyVal Int deriving Show++-- A specialized version of return for the Identity monad.+-- It is needed only for the Simple version of the code,+-- to tell the type checker the monad in which the computation is+-- taking place.+-- For the TF version of the code, we can use the ordinary return+-- in place of retI.+retI :: a -> Identity a+retI = return++-- A sample TIP+tip1 = MyVal 20 .*. (1::Int) .*. True .*. (3.5::Float) .*. emptyTIP+-- TIP (HCons (MyVal 20) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Update the Int component of tip1 to 2. The Int component must+-- exist. Otherwise, it is a type error+-- tip2 = runIdentity $ ttipM (retI (2::Int)) tip1 -- !Simple+tip2 = runIdentity $ ttipM (return (2::Int)) tip1  -- !TF+-- TIP (HCons (MyVal 20) (HCons 2 (HCons True (HCons 3.5 HNil))))+++-- Negate the boolean component of tip1+-- tip3 = runIdentity $ ttipM (retI . not) tip1 -- !Simple+tip3 = runIdentity $ ttipM (return . not) tip1      -- !TF+-- TIP (HCons (MyVal 20) (HCons 1 (HCons False (HCons 3.5 HNil))))++-- Update the Int component from the values of two other components+tip4 = runIdentity $ ttipM (\(MyVal x) y -> retI $ x+y) tip1+-- TIP (HCons (MyVal 20) (HCons 21 (HCons True (HCons 3.5 HNil))))++-- Update the MyVal component from the values of three other components+tip5 = runIdentity $ +       ttipM (\b (MyVal x) y -> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- The same but with the permuted argument order.+-- The order of arguments is immaterial: the values will be looked up using+-- their types+tip5' = runIdentity $ +        ttipM (\b y (MyVal x)-> retI $ MyVal $ if b then x+y else 0) tip1+-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil))))++-- Andrew Frank's test+-- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil)))))+tip6 :: IO (TIP (MyVal ': Int ': Bool ': Float ': '[]))+tip6 = ttipM op6 tip1++op6 :: MyVal -> Bool -> IO MyVal+op6 (MyVal x) b = do+                let m = if b then MyVal (x `div` 4) else MyVal (x * 4)+                putStrLn $ "MyVal is now " ++ show m+                            -- ==>> MyVal 5+                return m+-- TIP (HCons (MyVal 5) (HCons 1 (HCons True (HCons 3.5 HNil))))+++{-  -- !Simple+-- The Simple implementation+-- The drawback is the need to let the type checker know the monad in which the+-- computations take place. That is why we had to use retI in the above+-- code, which is a specialized version of return for the Identity monad. +-- In op6, the presence of putStrLn unambiguously specified the monad, viz. IO,+-- so no special return are required.++class Monad m => TransTIPM m op db where+    ttipM :: op -> db -> m db++-- If the operation is the computation in the desired monad,+-- the type of the computation must match an element of TIP.+instance (Monad m,+	  HTypeIndexed db, HUpdateAtHNat n op db db, HType2HNat op db n)+    => TransTIPM  m (m op) (TIP db) where+    ttipM op db = do+                     op' <- op+		     return $ tipyUpdate op' db++-- If op is not a computation in the desired monad m, +-- it must be a function. Look up its argument in a TIP and recur.+instance (Monad m, HOccurs arg db, TransTIPM m op db)+    => TransTIPM m (arg -> op) db where+    ttipM f db = ttipM (f (hOccurs db)) db+-} -- !Simple++-- {- -- !TF+-- The TF implementation. When specifying the operation to perform over+-- a TIP, we can leave it polymorphic over the monad. The type checker+-- will instantiate the monad based on the context.++class Monad m => TransTIPM m op db where+    ttipM :: op -> db -> m db++-- Check to see if the operation is a computation whose result+-- is in the TIP. The type variable m' of the kind *->* below +-- can be instantiated either to a monad type constructor, or (arg->).+instance (Monad m, HMember op db b, TransTIPM' b m (m' op) (TIP db))+    => TransTIPM m (m' op) (TIP db) where+    ttipM = ttipM' (proxy :: Proxy b)++class Monad m => TransTIPM' (b :: Bool) m op db where+    ttipM' :: Proxy b -> op -> db -> m db++-- If op is found in a TIP, update the TIP with op.+-- The type variable m' must be equal to the type of the monad+-- in which the final result is reported.+instance (Monad m, m ~ m',+	  HTypeIndexed db, HUpdateAtHNat n op db, HUpdateAtHNatR n op db ~ db, HType2HNat op db n)+    => TransTIPM' True m (m' op) (TIP db) where+    ttipM' _ op db = do+                     op' <- op+		     return $ tipyUpdate op' db++-- If op is not found in a TIP, it must be a function. Look up+-- its argument in a TIP and recur.+instance (Monad m, HOccurs arg db, TransTIPM m op db)+    => TransTIPM' False m (arg-> op) db where+    ttipM' _ f db = ttipM (f (hOccurs db)) db+-- -} -- !TF++main :: IO ()+main = do+            mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4,+                    show tip5, show tip5']+            tip2 <- tip6+            putStrLn $ "tip2 is" ++ show tip2+            return ()+
+ examples/TIPTransformM.out view
@@ -0,0 +1,8 @@+TIPH[MyVal 20, 1, True, 3.5]+TIPH[MyVal 20, 2, True, 3.5]+TIPH[MyVal 20, 1, False, 3.5]+TIPH[MyVal 20, 21, True, 3.5]+TIPH[MyVal 21, 1, True, 3.5]+TIPH[MyVal 21, 1, True, 3.5]+MyVal is now MyVal 5+tip2 isTIPH[MyVal 5, 1, True, 3.5]
+ examples/TIPTransformM.ref view
@@ -0,0 +1,8 @@+TIPH[MyVal 20, 1, True, 3.5]+TIPH[MyVal 20, 2, True, 3.5]+TIPH[MyVal 20, 1, False, 3.5]+TIPH[MyVal 20, 21, True, 3.5]+TIPH[MyVal 21, 1, True, 3.5]+TIPH[MyVal 21, 1, True, 3.5]+MyVal is now MyVal 5+tip2 isTIPH[MyVal 5, 1, True, 3.5]
+ 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.out view
+ 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.out view
+ 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/TypeEqBoolTTypeable.out view
+ 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/TypeEqExplosive.out view
+ 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/TypeEqTTypeable.out view
+ 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/cmdargs.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where+import System.Console.CmdArgs+import Data.HList.CommonMain+import Data.Generics+++{-++An example showing off the data instance for Record++Also a use of cmdArgs++NOTE: the data instances do not work with ghc-7.8 because of+<http://ghc.haskell.org/trac/ghc/ticket/8486>+++-}++makeLabels6 (words "x y z")+++d0 = x .=. (5 :: Int)+    .*. y .=. True+    .*. z .=. False+    .*. emptyRecord+++data E = E { a :: Int, b, c :: Bool }+    deriving (Show, Data, Typeable)+e0 = E 5 True False++main = do+    print d0+    print $ gmapT (mkT not) d0+    print $ gmapT (mkT (+(1::Int))) d0++    print $ fromConstrB (undefined `extB` (1::Int) `extB` True) undefined `asTypeOf` d0++    rc <- cmdArgs d0+    print rc+
+ examples/cmdargs.out view
@@ -0,0 +1,5 @@+Record{x=5,y=True,z=False}+Record{x=5,y=False,z=True}+Record{x=6,y=True,z=False}+Record{x=1,y=True,z=True}+Record{x=5,y=True,z=False}
+ examples/cmdargs.ref view
@@ -0,0 +1,5 @@+Record{x=5,y=True,z=False}+Record{x=5,y=False,z=True}+Record{x=6,y=True,z=False}+Record{x=1,y=True,z=True}+Record{x=5,y=True,z=False}
+ examples/labelable.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds #-}+{- | Demonstrates @hLens'@++may be worthwhile to have a lens-free test suite, doing stuff like:++> case x (Identity  . (++"there")) r of Identity t -> t++-}+module Main where+import Data.HList.CommonMain+import Control.Lens++makeLabelable "x y"++r = x .==. "hi" .*.+    y .==. (y .==. 321 .*. x .==. 123 .*. emptyRecord) .*.+    emptyRecord++main = do+    print (r ^. x)+    print (r & x .~ ())++    print (r ^. y . y)+    print (r & y . y .~ "xy")
+ examples/labelable.out view
@@ -0,0 +1,4 @@+"hi"+Record{x=(),y=Record{y=321,x=123}}+321+Record{x="hi",y=Record{y="xy",x=123}}
+ examples/labelable.ref view
@@ -0,0 +1,4 @@+"hi"+Record{x=(),y=Record{y=321,x=123}}+321+Record{x="hi",y=Record{y="xy",x=123}}
+ examples/labelable2.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds #-}+{- | Demonstrates @hLens'@++may be worthwhile to have a lens-free test suite, doing stuff like:++> case x (Identity  . (++"there")) r of Identity t -> t++-}+module Main where+import Data.HList.CommonMain+import Control.Lens++makeLabelable "x y"++r = x .==. "hi" .*.+    y .==. (y .==. 321 .*. x .==. 123 .*. emptyRecord) .*.+    emptyRecord++main = do+    print (r ^. x)+    print (r & x .~ ())++    print (r ^. y . y)+    print (r & y . y .~ "xy")
+ examples/lens.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds #-}+{- | Demonstrates @hLens@. See also labelable.hs which is more "convenient"++-}+module Main where+import Data.HList.CommonMain+import Control.Lens++makeLabels6 (words "x y")++r = x .=. "hi" .*.+    y .=. (y .=. 321 .*. x .=. 123 .*. emptyRecord) .*.+    emptyRecord++x' a = hLens x a+y' a = hLens y a++main = do+    print (view (hLens x) r)+    print (set (hLens x) () r)++    print (r ^. hLens y . hLens x)+    print (r & hLens y . hLens y .~ "xy")+++    putStrLn "\n\nand repeat:"++    -- and now for with hLens applied second+    print (view x' r)+    print (set x' () r)++    print (r ^. y' . y')+    print (r & y' . y' .~ "xy")+
+ examples/lens.out view
@@ -0,0 +1,11 @@+"hi"+Record{x=(),y=Record{y=321,x=123}}+123+Record{x="hi",y=Record{y="xy",x=123}}+++and repeat:+"hi"+Record{x=(),y=Record{y=321,x=123}}+321+Record{x="hi",y=Record{y="xy",x=123}}
+ examples/lens.ref view
@@ -0,0 +1,11 @@+"hi"+Record{x=(),y=Record{y=321,x=123}}+123+Record{x="hi",y=Record{y="xy",x=123}}+++and repeat:+"hi"+Record{x=(),y=Record{y=321,x=123}}+321+Record{x="hi",y=Record{y="xy",x=123}}
+ examples/pun.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+-- more examples for record puns+module Main where+import Data.HList.CommonMain++makeLabels6 (words "a b c")+++r  = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord+r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord+++p1 ( (.!. b) -> (b @ ((.!. a) -> a))) = (a,b)++p2 [pun| b @ {a} |] = (a, b)++-- same as p2, but gives a warning+-- p3 [pun| b @ a |] = (a, b)++p4 [pun| b{a} |] = a -- b is not bound++-- adds `x' and `y' into a field called r+e1 = let x = 1; y = "hi" in [pun| r @ { x y } |]++-- updates the `c' field+e2 = let c = 1; y = "hi" in [pun| r @ { c y } |]++-- same as e1, but doesn't use a pre-existing r+e3 = let x = 1; y = "hi" in [pun| r { x y } |]+++main = do+        putStrLn "similar:"+        print $ p1 r+        print $ p2 r+        print $ p4 r++        putStrLn "\nexpression QQ:"+        print $ e1+        print $ e2+        print $ e3+
+ examples/pun.out view
@@ -0,0 +1,9 @@+similar:+(3,Record{a=3})+(3,Record{a=3})+3++expression QQ:+Record{r=Record{b=Record{a=3},c="c",x=1,y="hi"}}+Record{r=Record{b=Record{a=3},c=1,y="hi"}}+Record{r=Record{x=1,y="hi"}}
+ examples/pun.ref view
@@ -0,0 +1,9 @@+similar:+(3,Record{a=3})+(3,Record{a=3})+3++expression QQ:+Record{r=Record{b=Record{a=3},c="c",x=1,y="hi"}}+Record{r=Record{b=Record{a=3},c=1,y="hi"}}+Record{r=Record{x=1,y="hi"}}
+ examples/rundoctests.hs view
@@ -0,0 +1,40 @@+import System.Process+import System.Exit+import System.IO+import Test.DocTest+import Data.Char+import System.Environment++-- | 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+    o <- readProcess+        "cabal" ["repl","--ghc-options","-v0 -w"]+        ":show packages\n:show language"+    let flags = words $ unlines $ 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"]+            _ -> as++    doctest $ "-i.": "-idist/build/autogen":+             "-optP-include":+             "-optPdist/build/autogen/cabal_macros.h" :+             "-Idist/build/autogen" : "-w":+             files ++ flags
+ examples/runexamples.hs view
@@ -0,0 +1,55 @@+module Main where++import Control.Exception+import System.FilePath+import Test.Hspec+import System.Process+import System.Exit+import System.Directory+import Data.Maybe+import Control.Monad++main = do++  es <- getDirectoryContents "examples"+++  print es+  -- very dumb+  es <- filterM (\e -> allM+    [return (takeExtension e == ".hs"),+     doesFileExist (dropExtension ("examples"</>e) ++ ".ref") ]) es++  print es++  hspec $ do+    mapM_ runghcwith es+++runghcwith f = describe f $ it "ok" $ checkResult $+  do+    let ex = ("examples" </>)+    let inFile = ex (takeBaseName f)+        outFile = dropExtension inFile ++ ".out"+        refFile = dropExtension inFile ++ ".ref"++    (ec, stdout, stderr) <- readProcessWithExitCode "cabal" ["repl","-v0",+        "--ghc-options", "-w -fcontext-stack=50 -iexamples -v0 "]+        (":load " ++ inFile ++ "\nmain")++    writeFile outFile stdout++    ofe <- doesFileExist refFile+    diff <- if ofe then fmap Just $+        readProcess "diff" ["-b", outFile, refFile] "" else return Nothing++    return (ec, stderr, diff)+ where+  checkResult io = io `shouldReturn` (ExitSuccess, "", Just "")++++allM [] = return True+allM (x:xs) = do+    x <- x+    if x then allM xs else return False