packages feed

quick-process 0.0.1 → 0.0.3

raw patch · 60 files changed

+12031/−267 lines, 60 filesdep +arraydep +base-orphansdep +generic-datadep −HListdep −prettydep ~basedep ~containersdep ~mtl

Dependencies added: array, base-orphans, generic-data, generic-deriving, ghc-prim, monad-time, pretty-simple, profunctors, tagged, wl-pprint-text

Dependencies removed: HList, pretty

Dependency ranges changed: base, containers, mtl, time, trace-embrace

Files

changelog.md view
@@ -1,4 +1,13 @@ # trace-embrace changelog +## Version 0.0.3 2025-06-24+  * GHC 9.12+  * Outcome checkers+  * ConstArgs - list of ConstArg+  * Benchmark execution+  * Protection from lost imports+  * Call spec cascades+  * Include forked HList, multi-containers, refined, conduit-find+ ## Version 0.0.1 2025-06-01   * init
+ hlist/Data/HList.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE MagicHash #-}+{- |+OOHaskell (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++This module gathers the API that we need for OOP in Haskell.  We+basically select a certain configuration of the HList library, and we+also import modules that are needed for mutable data and monads. Note+on overlapping: Needed for the chosen model of labels. Other models+can be used instead, but the chosen look better in types.+-}+++module Data.HList (++ module Data.HList.CommonMain,+ -- 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 DeepNarrow,+-- module Nominal,+-- module New,+-- module Data.HList.HList+ concrete,+ (#)+) where+++import Data.HList.CommonMain hiding ( HDeleteMany+                         , hDeleteMany+                         )++-- import Data.HList.RecordAdv++import Data.STRef+import Data.IORef+import Data.Typeable+import Control.Monad+import Control.Monad.ST+import Control.Monad.Fix++infixr 9 #+(#) :: 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++
+ hlist/Data/HList/CommonMain.hs view
@@ -0,0 +1,331 @@+{- |++   Description : import me+   Copyright   : (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   The HList library++   This module re-exports everything needed to use HList.++-}++module Data.HList.CommonMain (++ -- * Faking dependent types in Haskell+   module Data.HList.FakePrelude++ -- * Functions for all collections+ , module Data.HList.HListPrelude+ -- * Array-like access to HLists+ , module Data.HList.HArray+ -- * Result-type-driven operations+ , module Data.HList.HOccurs+ -- * Type-indexed operations+ , module Data.HList.HTypeIndexed++ -- * Record+ , module Data.HList.Record+ -- | quasiquoter 'pun' helps to avoid needing a proxy value with+ -- type 'Label' in the first place: when you take values out of or into+ -- records with pattern matching, the variable name determines the label+ -- name.+ , module Data.HList.RecordPuns++ -- ** Unpacked / Unboxed Records+ , RecordU+ , RecordUS+ , SortForRecordUS(..)+ , HUpdateMany(..)+ , hMapRU++ -- *** internals for types+ , HFindMany, HNats2Integrals(..)++ , RecordUSCxt+ , HLookupByHNatUS, HLookupByHNatUS1+ , HSubtract, HMapUnboxF, UnboxF+ , BoxF, EqTagValue, GetElemTy, ElemTyEq+ , RecordToRecordU, RecordUToRecord++ -- * HList+ -- | A subset of "Data.HList.HList" is re-exported.+ , module Data.HList.HList+ , module Data.HList.HZip+ -- ** A subset of "Data.HList.HSort"+ , hSort+ , HSort+ , HSortBy(..)+ , HLeFn, HDown+ , HSet, HSetBy+ , HIsSet, HIsSetBy+ , HAscList, HIsAscList++ -- ** A subset of "Data.HList.HCurry"+ , HCurry'(..)+ , hCurry, hUncurry+ , hCompose++ -- * TIP+ -- | Public interface of "Data.HList.TIP"+ , TIP+ , emptyTIP+ , tipyUpdate+ , tipyLens+ , tipyLens'+ -- ** projection+ , tipyProject+ , tipyProject2+ , tipyTuple+ , tipyTuple3+ , tipyTuple4+ , tipyTuple5+ , TagUntag, TagUntagFD(..)+ , TagR++ -- ** TIP transform+ , TransTIP(..)+ , TransTIPM(..)++ -- * TIC+ -- | Public interface of "Data.HList.TIC"+ , TIC+ -- ** creating TIC+ , mkTIC+ , mkTIC1+ , mkTIC'++ -- ** get,set,modify+ , ticPrism, ticPrism'++ -- * Variant+ -- | Public interface of "Data.HList.Variant"+ , Variant+ , mkVariant+ , mkVariant1+ , castVariant+ , HMapV(..), hMapV+ , hMapOutV+ , ZipVariant(..)+ , ZipVR(..), zipVR+ -- ** projection+ -- *** many+ , SplitVariant(splitVariant)+ , ProjectVariant(..)+ , ExtendsVariant(..)+ , ProjectExtendVariant(..)+ -- *** one+ , HPrism(..)+ , unvarianted, unvarianted'++ , splitVariant1+ , splitVariant1'+ , extendVariant+ -- **** implementation+ , Unvariant(..)+ , Unvariant'(..)++++ -- * Conversions between collections+ -- $convention the foo' optic has the same type as+ -- @Control.Lens.simple . foo . Control.Lens.simple@.+ -- 'hLens'' is an exception to this rule.++ , TypeIndexed(..)+ , typeIndexed'+ -- ** HList and Record+ -- | 'unlabeled' 'unlabeled''++ -- ** HList and TIP+ , tipHList, tipHList'+ -- ** Record and RecordU+ , unboxed, unboxed'+ -- ** Record and RecordUS+ , unboxedS, unboxedS'+ -- ** Record and Variant+ , hMaybied, hMaybied'++ -- ** Newtype wrappers+ -- $convention these isos unwrap/wrap the newtypes 'TIP' 'TIC' and+ -- 'Record'. Names follow the pattern @fromTo :: Iso' From To@.++ -- | 'hListRecord' 'hListRecord'' are exported under "Data.HList.Record"+ , ticVariant, ticVariant'+ , tipRecord, tipRecord'++ -- *** implementation+ , VariantToHMaybied(variantToHMaybied)+ , HMaybiedToVariantFs+ , hMaybiedToVariants++ -- * "Data.HList.Keyword"+ -- | the \"public\" parts. More examples are in the module documentation.+ , Kw(..), recToKW, IsKeyFN, K,  ErrReqdArgNotFound,  ErrUnexpectedKW++ -- * Labels+ {- | By labels, we mean either the first argument to 'Tagged' (in the+   type-level lists that are supplied to 'Record', 'RecordU', 'TIP', 'TIC'),+   or the expressions used to specify those types to be able to look up+   the correct value in those collections.++   Nearly all types can be labels. For example:++   @+     r :: Record '[Tagged "x" Int,   -- kind GHC.TypeLits.Symbol +                   Tagged () (),    -- see "Data.HList.Label5"+                   Tagged (Lbl HZero LabelUniverse LabelMember1) () -- Label3+                  ]+     r = 'hBuild' 8 () () -- don't need to use '.=.' / '.==.' and '.*.'+                           -- if we have a type signature above+   @+ +    we could define these variables++   @+    xLabel = Label :: Label \"x\" -- 'makeLabels6' ["x"] would define x with the same RHS+    xLens  = hLens' xLabel        -- 'makeLabelable' "x" would define x with the same RHS+   @++   to access the @8@ given above:++   @+    r '.!.' xLabel+    r  ^.   xLens   -- alternatively Control.Lens.view+    r  ^. `x        -- with HListPP is used (not in ghci),+                    -- which avoids the issue of conflicting+                    -- definitions of x, which mean the same+                    -- thing+   @++ -}+ -- $label6demo++ , module Data.HList.Labelable+ -- $labelable++ -- ** "Data.HList.Dredge"+ -- *** lenses+ , dredge, dredge'+ , dredgeND, dredgeND'+ , dredgeTI'+ -- *** plain lookup+ , hLookupByLabelDredge, HasFieldPath++ -- ** namespaced labels+ , module Data.HList.Label3++ -- ** labels as any instance of Typeable+ --  | "Data.HList.Label5"++ -- ** template haskell+ , module Data.HList.MakeLabels+++ -- * "Data.HList.Data"+ -- | This modules provide useful instances. A useful application can be+ -- found in @examples/cmdargs.hs@++ -- | Overlapping instances are restricted to here+ , module Data.HList.TypeEqO++ -- * Internals+ -- | internals exported for type signature purposes+ , HAllTaggedEq+) where++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import Data.HList.HArray+import Data.HList.HOccurs+import Data.HList.HTypeIndexed+import Data.HList.Record+-- import Data.HList.RecordOrd+import Data.HList.HList hiding (append',+                                hAppend',+                                FHCons(..),+                                hMapAux,+                                MapCar(..),+                                hMapMapCar,+                                hSequence2,+                                )+import Data.HList.HCurry+import Data.HList.HSort+import Data.HList.MakeLabels+import Data.HList.TypeEqO hiding (IsKeyFN)+import Data.HList.TIP+import Data.HList.TIC++import Data.HList.HZip+import Data.HList.Label3 hiding (MapLabel)+import Data.HList.Label5 () -- only instances+import Data.HList.Label6 () -- only instances+import Data.HList.Labelable (Labelable(..),+                             Projected(..), projected',+                             toLabel,+                             (.==.),+                             LabeledOptic)++import Data.HList.Variant++import Data.HList.Data () -- only instances++import Data.HList.Keyword+import Data.HList.RecordPuns+import Data.HList.RecordU++import Data.HList.Dredge++{- $label6demo #label6demo#++ Instances from "Data.HList.Label6"++>>> :set -XDataKinds+>>> (Label :: Label "x") .=. (5::Int) .*. emptyRecord+Record{x=5}++>>> let x = Label :: Label "x"+>>> let r = x .=. (5::Int) .*. emptyRecord+>>> r .!. x+5++-}++{- $labelable #labelabledemo#++Rather than having the @x = Label :: Label \"x\"@, the labels+generated by 'makeLabelable' also double as lenses for "Control.Lens".+Here is an example of how much better that is:++>>> :set -XNoMonomorphismRestriction -XDataKinds -XPolyKinds+>>> import Control.Lens+>>> import Data.HList.Labelable+>>> let x = hLens' (Label :: Label "x")+>>> let y = hLens' (Label :: Label "y")++The Label6 method:++>>> let r = (Label :: Label "x") .=. "5" .*. emptyRecord++The Labelable way:++>>> let r2 = x .==. "5" .*. emptyRecord++>>> r ^. x+"5"++>>> r2 ^. x+"5"++>>> r & x .~ ()+Record{x=()}++When a field is missing, the error names that field:++>>> :t r^.y+...+...No instance for (Fail (FieldNotFound "y"))+...++-}++
+ hlist/Data/HList/Data.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE CPP #-}++{- | Description: Data instances+++'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend+to be flat data structures. The @Data@ instance for 'HList' gives a nested+structure.++NOTE: these instances do not work with ghc-7.8 with promoted+string (Symbol) labels because of+<https://ghc.haskell.org/trac/ghc/ticket/9111>++[@HList@]++The data instance for++> a :: HList '[Int, Double, b]++Looks like the same instance for++> type T b = (Int, (Double, (b, ())))+++[@HListFlat@]++The Data instance for++> a :: Data b => HListFlat '[Int,Double,b]++will look like the Data instance for:++> data A b = A Int Double b+++[@Record@]++For 'Record' similar ideas apply. An++> a :: Record '[ LVPair "x" Int, LVPair "y" Double ]++should behave like a:++> data A = A { x :: Int, y :: Double } deriving (Data)++Many unsafecoerces are necessary here because the Data class includes type+parameters @c@ that cannot be used in the class context for the instance.+Perhaps there is another way.++-}+module Data.HList.Data (+    -- * exports for type signatures/ haddock usage+    DataHListFlatCxt,+    DataRecordCxt,+    TypeRepsList(..),++    -- ** less likely to be used+    RecordLabelsStr(..),+    GfoldlK(..),+    GunfoldK(..),+    HListFlat(..),+    TypeablePolyK,+    ) where++import Data.HList.FakePrelude+import Data.HList.HList+import Data.HList.Record+import Data.HList.Variant+import Data.Data+import Data.HList.TIC+import Data.HList.TIP++-- for Typeable '[] and Typeable '(:) with ghc-7.6+import Data.Orphans ()++#if OLD_TYPEABLE+import Data.List+#endif++import Unsafe.Coerce+++deriving instance Typeable (HList '[]) => Data (HList '[])+deriving instance+    (Data x,+     Data (HList xs),+     TypeablePolyK (x ': xs), -- for new typeable+     Typeable (HList (x ': xs) -- for old typeable+     )) => Data (HList (x ': xs))++deriving instance+    (TypeablePolyK xs,+     Typeable (HList xs),+     Data (HList xs)) => Data (TIP xs)+deriving instance+    (TypeablePolyK xs,+     Typeable (Variant xs),+     Data (Variant xs)) => Data (TIC xs)++-- | this data type only exists to have Data instance+newtype HListFlat a = HListFlat (HList a)++type DataHListFlatCxt na g a = (+        g ~ FoldRArrow a (HList a),+        HBuild' '[] g,+        Typeable (HListFlat a),+        TypeablePolyK a,+        HFoldl (GfoldlK  C) (C g) a (C (HList a)),++        HFoldr+            (GunfoldK C)+            (C g)+            (HReplicateR na ())+            (C (HList a)),++        HLengthEq a na,+        HReplicate na ())+++-- | ghc-8.0.2 can't work out the type g,+-- in the 2nd argument of gfoldl. ghc <= 7.10+-- don't need it.+--+-- in `instance Data (HListFlat '[a,b,c])`+--+-- > g ~ (a -> b -> c -> HList '[a,b,c])+-- > g ~ GetG '[a,b,c] (HList '[a,b,c])+type family FoldRArrow (xs :: [*]) (r :: *)++type instance FoldRArrow '[] r = r+type instance FoldRArrow (x ': xs) r = x -> FoldRArrow xs r+++instance DataHListFlatCxt na g a => Data (HListFlat a) where+    gfoldl k z (HListFlat xs) = c3 $+                    hFoldl+                        (c1 (GfoldlK k))+                        (c2 (z hBuild))+                        xs+        where+              c1 :: forall c. GfoldlK c -> GfoldlK C+              c1 = unsafeCoerce++              c2 :: forall c. c g -> C g+              c2 = unsafeCoerce++              c3 :: forall c. C (HList a) -> c (HListFlat a)+              c3 = unsafeCoerce++    gunfold k z _ =+              c3 $ withSelf $ \self ->+                hFoldr+                    (c1 (GunfoldK k))+                    (c2 (z hBuild))+                    (hReplicate (hLength self) ())+        where+              withSelf :: forall t c. (t -> c t) -> c t+              withSelf x = x undefined++              c1 :: forall c. GunfoldK c -> GunfoldK C+              c1 = unsafeCoerce++              c2 :: forall c. c g -> C g+              c2 = unsafeCoerce++              c3 :: forall c. C (HList a) -> c (HListFlat a)+              c3 = unsafeCoerce++    dataTypeOf _ = hListFlatDataRep+    toConstr _   = hListFlatConRep++hListFlatDataRep = mkDataType "Data.HList.HList" [hListFlatConRep]+hListFlatConRep = mkConstr hListFlatDataRep "HListFlat" [] Prefix++type DataRecordCxt a =+    (Data (HListFlat (RecordValuesR a)),+            TypeablePolyK a,+            TypeRepsList (Record a),+            RecordValues a,+            RecordLabelsStr a)++instance DataRecordCxt a => Data (Record a) where+    gfoldl k z xs = c1 (gfoldl k z (HListFlat (recordValues xs)))+        where+            c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a)+            c1 = unsafeCoerce++    gunfold k z con = c1 (gunfold k z con)+        where+            -- LVPair and Record are newtypes, so this should be safe...+            c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a)+            c1 = unsafeCoerce++    dataTypeOf x = snd (recordReps (recordLabelsStr x))+    toConstr x = fst (recordReps (recordLabelsStr x))+++recordReps fields =+    let c = mkConstr d "Record" fields Prefix+        d = mkDataType "Data.HList.Record" [c]+    in (c,d)++++class RecordLabelsStr (xs :: [*]) where+    recordLabelsStr :: Record xs -> [String]++instance RecordLabelsStr '[] where+    recordLabelsStr _ = []+instance (RecordLabelsStr xs,+          ShowLabel x) => RecordLabelsStr (Tagged x t ': xs) where+    recordLabelsStr _ = showLabel (Label :: Label x) :+                            recordLabelsStr (undefined :: Record xs)++{- |++This alternative option works too, but for whatever reason+splitting up recordLabelsStr and recordLabels into two functions+means that a type annotation is needed on the 3, which is not+necessary with the above recordLabelsStr (ghc-7.6.3)++> recordLabelsStr2 (recordLabels (((Label :: Label "x") .=. 3 .*. emptyRecord )))++-}+class RecordLabelsStr2 (xs :: [k]) where+    recordLabelsStr2 :: proxy xs -> [String]++instance RecordLabelsStr2 '[] where+    recordLabelsStr2 _ = []+instance (RecordLabelsStr2 xs,+          ShowLabel x) => RecordLabelsStr2 (x ': xs) where+    recordLabelsStr2 _ = showLabel (Label :: Label x) :+                            recordLabelsStr2 (Proxy :: Proxy xs)+++-- | use only with @instance Data (HList a)@. This is because the HFoldl+-- context cannot be written for a @c@ that only appears in the method+-- 'gfoldl'.+data C a++class TypeRepsList a where+  typeRepsList :: a -> [TypeRep]+++instance (TypeRepsList (HList xs)) => TypeRepsList (Record xs) where+  typeRepsList (Record xs) = typeRepsList xs++instance (TypeRepsList (HList xs), Typeable x) => TypeRepsList (HList (x ': xs)) where+  typeRepsList (~(x `HCons` xs))+        = typeOf x : typeRepsList xs++instance TypeRepsList (HList '[]) where+  typeRepsList _ = []++++-- | wraps up the first argument to 'gfoldl'+data GfoldlK c where+    GfoldlK :: (forall d b . Data d => c (d -> b) -> d -> c b) -> GfoldlK c++instance (Data d, (c (d -> b), d) ~ x, c b ~ y) =>+        ApplyAB (GfoldlK c) x y where+    applyAB (GfoldlK f) (u,v) = f u v+++data GunfoldK c where+    GunfoldK :: (forall b r. Data b => c (b -> r) -> c r) -> GunfoldK c++instance (Data b, x ~ (t, c (b -> r)), y ~ c r) =>+        ApplyAB (GunfoldK c) x y where+    applyAB (GunfoldK f) (_, u) = f u
+ hlist/Data/HList/Dredge.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+-- TryCollectionList needs overlap+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+{- | Description: access nested records/variants given only the last label along a path -}+module Data.HList.Dredge where++import Data.HList.Record+import Data.HList.Variant+import Data.HList.HList+import Data.HList.TIP+import Data.HList.TIC+import Data.HList.FakePrelude+import Data.HList.Labelable+import LensDefs (isSimple)+import Data.HList.TypeEqO () -- if this is missing, dredge fails+++#if (__GLASGOW_HASKELL__ == 800)+-- https://ghc.haskell.org/trac/ghc/ticket/13371+toLabelx x = toLabelSym x+#else+toLabelx x = toLabel x+#endif++{- |++Using HListPP syntax for short hand, @dredge `foo@ expands out to+something like @`path . `to . `foo@, with the restriction that+there is only one possible @`path .  `to@ which leads to the+label @foo@.++For example, if we have the following definitions,++> type BVal a = Record '[Tagged "x" a, Tagged "a" Char]+> type R a = Record  [Tagged "a" Int, Tagged "b" (BVal a)]+> type V a = Variant [Tagged "a" Int, Tagged "b" (BVal a)]+> lx = Label :: Label "x"++Then we have:++> dredge `x :: Lens (R a) (R b) a b+> dredge lx :: Lens (R a) (R b) a b++> dredge `x :: Traversal (V a) (V b) a b -- there were only variants along the path we'd get a Prism+> dredge lx :: Traversal (V a) (V b) a b++[@result-type directed operations are supported@]++There are two ways to access a field with tag @a@ in the R type+defined above, but they result in fields with different types+being looked up:++> `a        :: Lens' (R a) Char+> `b . `a   :: Lens' (R a) Int++so provided that the result type is disambiguated by the context,+the following two types can happen++> dredge `a :: Lens' (R a) Char+> dredge `a :: Lens' (R a) Int+++[@TIP & TIC@]++type indexed collections are allowed along those paths, but+as explained in the 'Labelable' instances, only simple optics+(Lens' / Prism' / Traversal' ) are produced. @dredgeTI'@+works better if the target is a TIP or TIC++-}+dredge label = getSAfromOutputOptic $ \ pr pa ->+      hLens'Path (labelPathEndingWithTD pr (toLabelx label) pa)++++getSAfromOutputOptic :: (p a fb -> p rs rft) ~ stab+                => (Proxy (rs :: *) -> Proxy (a :: *) -> stab) -> stab+getSAfromOutputOptic f = f Proxy Proxy+++-- | 'dredge' except a simple (s ~ t, a ~ b) optic is produced+dredge' label = isSimple (dredge label)+++-- | dredgeND (named directed only) is the same as 'dredge', except the+-- result type (@a@) is not used when the label would otherwise+-- be ambiguous. dredgeND might give better type errors, but otherwise+-- there should be no reason to pick it over dredge+dredgeND label = getSAfromOutputOptic $ \ pr _a ->+      hLens'Path (labelPathEndingWith pr (toLabelx label))+++-- | 'dredgeND' except a simple (s ~ t, a ~ b) optic is produced+dredgeND' label = isSimple (dredgeND label)+++{- | The same as dredgeND', except intended for TIP/TICs because+the assumption is made that @l ~ v@ for the @Tagged l v@ elements.+In other words, ticPrism' and 'tipyLens'' could usually+be replaced by++> dredgeTI' :: _ => Label a -> Lens'  (TIP s) a+> dredgeTI' :: _ => Label a -> Prism' (TIC s) a++where we might have @s ~ '[Tagged a a, Tagged b b]@++-}+dredgeTI' label = isSimple lens where+        lens = getSAfromOutputOptic $ \ pr pa ->+            hLens'Path (labelPathEndingWith pr (pa `proxyTypeOf` label))++        proxyTypeOf :: p a -> q a -> Label a+        proxyTypeOf _ _ = Label+++-- | @HSingleton msg xs x@ is like @'[x] ~ xs@ if that constraint can hold,+-- otherwise it is @Fail msg@. See comments on 'Fail' about how its kind+-- varies with ghc version.+class HSingleton (msgAmb :: m) (msgEmpty :: m2) (ns :: [k]) (p :: k) | ns -> p+instance HSingleton m1 m2 '[n] n+instance (Fail m2, Any ~ a) => HSingleton m1 m2 '[] a+instance (Fail m1, Any ~ a) => HSingleton m1 m2 (n1 ': n2 ': n3) a+++-- | @HGuardNonNull msg xs@ is like @when (null xs) (fail msg)@+class HGuardNonNull emptymsg (xs :: [k])++instance Fail msg => HGuardNonNull msg '[]+instance             HGuardNonNull msg (x ': xs)+++-- | @ConsTrue b x xs r@ is like @r = if b then x:xs else xs@+class ConsTrue (b :: Bool) (x :: k) (xs :: [k]) (r :: [k]) | b x xs -> r, r b -> xs, x xs r -> b+instance ConsTrue True x xs (x ': xs)+instance ConsTrue False x xs xs++-- | @FilterLastEq x xs ys ys'@ determines ys' such that it+-- contains all of the @ys !! i@ such that @last (xs !! i) == x@.+-- In other words it is like+--+-- > ys' = [ y |  (xsElt, y) <- zip xs ys, last xsElt == x ]+class FilterLastEq (x :: k) (xs :: [[k]]) (ys :: [m]) (ys' :: [m]) | x xs ys -> ys'+instance (HReverse path (y' ': rest), HEq y y' b, ConsTrue b z r1 r,+          FilterLastEq y xs zs r1) => FilterLastEq y (path ': xs) (z ': zs) r++instance FilterLastEq y '[] '[] '[]++-- | The same as 'FilterLastEq' except @id@ is used instead of @last@+class FilterVEq (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'++instance FilterVEq v '[] '[] '[]++instance+   (HEq v v' b,+    ConsTrue b n ns1 ns2,+    FilterVEq v vs ns ns1)+    => FilterVEq v (v' ': vs) (n ': ns) ns2++-- | like @FilterVEq@, except if there is+class FilterVEq1 (v :: *) (vs :: [*]) (ns :: [k]) (ns' :: [k]) | v vs ns -> ns'+instance (v ~ v') => FilterVEq1 v '[ v' ] ns ns+instance FilterVEq1 v '[] '[] '[]+instance FilterVEq v (a ': b ': c)  ns ns' => FilterVEq1 v (a ': b ': c) ns ns'++-- | @LabelPathEndingWith r l path@+--+-- determines a unique path suitable for 'hLookupByLabelPath'+-- (calling 'Fail' otherwise) through the+-- nested records/variants in r ending with l+class LabelPathEndingWith (r :: *) (l :: k) (path :: [*]) | r l -> path where+    labelPathEndingWith :: proxy r -> Label l -> Label path+    labelPathEndingWith _ _ = Label++instance+   (FieldTree r ns,+    FilterLastEq (Label l) ns ns ns',+    HSingleton (NonUnique' r l) (NamesDontMatch r ns l) ns' path)+    => LabelPathEndingWith r l path+++labelPathEndingWithTD :: forall r l v path+                                vs vs1 ns ns1 ns2.+   (SameLength ns vs,+    SameLength ns1 vs1,+    FieldTree r ns,+    FieldTreeVal r vs,+    FilterLastEq (Label l) ns ns ns1,+    FilterLastEq (Label l) ns vs vs1,+    FilterVEq1 v vs1 ns1 ns2,++    HGuardNonNull (NamesDontMatch r ns l) ns1,++    -- '[path] ~ ns2, plus error reporting if ns2 has >1 or 0 elements+    HSingleton (NonUnique r v l) (TypesDontMatch r ns1 vs1 v) ns2 path)+    => Proxy r -> Label l -> Proxy v -> Label path+labelPathEndingWithTD _ _ _ = Label+++type NamesDontMatch r ns l = ErrShowType r+  :$$: ErrText "has paths"  :<>: ErrShowType ns+  :$$: ErrText "but none which end in the desired label" :<>: ErrShowType l++type NonUnique' r l = ErrText "Path ending in label " :<>: ErrShowType l+  :$$: ErrText "is not unique in " :<>: ErrShowType r++type NonUnique r v l = NonUnique' r l+  :$$: ErrText "also considering the v type " :<>: ErrShowType v++{- | XXX++> let x = 'x'; y = [pun| x |]; z = [pun| y |]+> z & dredge (Label :: Label "x") %~ (succ :: Int -> Int)++Should reference this type error, but for whatever reason it doesn't++-}+type TypesDontMatch r ns1 vs1 v = ErrShowType r+  :$$: ErrText "has potential paths with the right labels" :<>: ErrShowType ns1+  :$$: ErrText "which point at types" :<>: ErrShowType vs1 :<>: ErrText "respectively"+  :$$: ErrText "but none of these match the desired type" :<>: ErrShowType v++-- | see 'hLookupByLabelPath'+hLookupByLabelDredge l r = labelPathEndingWith (toProxy r) l `hLookupByLabelPath` r+  where toProxy :: r x -> Proxy x+        toProxy _ = Proxy++{- | lookup along a path++>>> let v = mkVariant1 Label (mkVariant1 Label 'r') :: Variant '[Tagged "x" (Variant '[Tagged "y" Char])]+>>> let r = hBuild (hBuild 'r') :: Record '[Tagged "x" (Record '[Tagged "y" Char])]+>>> let p = Label :: Label [Label "x", Label "y"]+>>> let lx = Label :: Label "y"++>>> hLookupByLabelPath p v+Just 'r'++>>> hLookupByLabelPath p r+'r'++>>> hLookupByLabelDredge lx v+Just 'r'++>>> hLookupByLabelDredge lx r+'r'++-}+hLookupByLabelPath :: HasFieldPath False ls r v => Label ls -> r -> v+hLookupByLabelPath labels r = hLookupByLabelPath1 hFalse labels r++{- |++> hLens'Path labc == hLens' la . hLens' lb . hLens' lc+>  where+>       la :: Label "a"+>       lb :: Label "b"+>       lc :: Label "c"+>       labc :: Label '["a", "b", "c"]++-}+class LabelablePath (xs :: [*]) apb spt | spt xs -> apb where+    hLens'Path :: Label xs -> apb -> spt++instance (Labelable x r s t a b,+          j ~ (a `p` f b),+          k ~ (r s `p` f (r t)),+          ty ~ LabelableTy r,+          LabeledOpticP ty p,+          LabeledOpticF ty f,+          LabeledOpticTo ty x (->),+          LabelablePath xs i j) => LabelablePath (Label x ': xs) i k where+    hLens'Path _ = (hLens' (Label :: Label x) :: j -> k) . hLens'Path (Label :: Label xs)++instance (x ~ x') => LabelablePath '[] x x' where+    hLens'Path _ = id++class HasFieldPath (needJust :: Bool) (ls :: [*]) r v | needJust ls r -> v where+    -- | use 'hLookupByLabelPath' instead+    hLookupByLabelPath1 :: Proxy needJust -> Label ls -> r -> v++instance HasFieldPath False '[] v v where+    hLookupByLabelPath1 _ _ = id++instance HasFieldPath True '[] v (Maybe v) where+    hLookupByLabelPath1 _ _ = Just++instance (HasField l (Record r) u, HasFieldPath needJust ls u v)+    => HasFieldPath needJust (Label l ': ls) (Record r) v where+     hLookupByLabelPath1 needJust _ = hLookupByLabelPath1 needJust (Label :: Label ls)+                                . hLookupByLabel (Label :: Label l)++instance (HasField l (Variant r) (Maybe u), HasFieldPath True ls u (Maybe v))+    => HasFieldPath needJust (Label l ': ls) (Variant r) (Maybe v) where+     hLookupByLabelPath1 _ _ v = hLookupByLabelPath1 hTrue (Label :: Label ls) =<< hLookupByLabel (Label :: Label l) v++++++{- | @(FieldTree r ns, FieldTreeVal r vs)@++defines ns and vs such that looking up path (ns !! i) in r gives the type+(vs !! i). This is almost @HasFieldPath False (ns !! i) (vs !! i)@, except+there is no additional Maybe when a Variant is encountered along the path+(and we don't have a type level @!!@)+-}+class FieldTreeVal (r :: *) (v :: [*]) | r -> v++class MapFieldTreeVal (r :: *) (ns :: Maybe [*]) (vs :: [*]) | r ns -> vs++instance (TryCollectionList r ns, MapFieldTreeVal r ns v) => FieldTreeVal r v++instance MapFieldTreeVal r Nothing '[]++instance ( MapFieldTreeVal r (Just xs) out2,+           FieldTreeVal v out1,+           (v ': HAppendListR out1 out2) ~ out)+  => MapFieldTreeVal r (Just (Tagged n v ': xs))  out++instance MapFieldTreeVal r (Just '[]) '[]++{- | list all paths through nested records or variants.+An example instance would be++> FieldTree r v++where++> v ~ [[ Label "x",  Label Dat ], '[Label "y"], '[Label "x"] ]+> r ~ Record [ Tagged "x" x, Tagged "y" String ]+>+> x ~ Variant '[ Tagged Dat Char ]++-}+class FieldTree (r :: *) (v :: [[*]]) | r -> v++-- | the only instance+instance (TryCollectionList r ns, MapFieldTree ns vs) => FieldTree r vs+++#if (__GLASGOW_HASKELL__ >= 800)+-- possibly https://ghc.haskell.org/trac/ghc/ticket/13284+-- dredge' x = (isSimple . dredge) x+--     • Overlapping instances for TryCollectionList r0 ns0+--         arising from a use of ‘dredge’+--       Matching instances:+--         instance [overlappable] nothing ~ 'Nothing =>+--                                 TryCollectionList x nothing+--           -- Defined at /home/aavogt/wip/HList/HList/Data/HList/Dredge.hs:340:31+--         ...plus four instances involving out-of-scope types+--         (use -fprint-potential-instances to see them all)+--       (The choice depends on the instantiation of ‘r0, ns0’+--        To pick the first instance above, use IncoherentInstances+--        when compiling the other instance declarations)+--+-- attempt to resolve that with a closed type family++type family TryCollectionListTF (r :: *) :: Maybe [*] where+  TryCollectionListTF (Record r) = Just r+  TryCollectionListTF (Variant r) = Just r+  TryCollectionListTF (TIC r) = Just r+  TryCollectionListTF (TIP r) = Just r+  TryCollectionListTF nothing = Nothing++type TryCollectionList r v = (v ~ TryCollectionListTF r)++#else+-- | try to extract the list applied to the Record or Variant+class TryCollectionList (r :: *) (v :: Maybe [*]) | r -> v++instance {-# OVERLAPPABLE #-} (nothing ~ Nothing) => TryCollectionList x nothing+instance {-# OVERLAPPING  #-} TryCollectionList (Record  r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (Variant r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (TIC r) (Just r)+instance {-# OVERLAPPING  #-} TryCollectionList (TIP r) (Just r)+#endif++class MapFieldTree (ns :: Maybe [*]) (vs :: [[*]]) | ns -> vs++instance MapFieldTree Nothing '[]++-- | recursive case+instance (+    MapFieldTree (Just xs) vs3,+    FieldTree v vs1,+    MapCons (Label n) ('[] ': vs1) vs2,+    HAppendListR vs2 vs3 ~ vs)+    => MapFieldTree (Just (Tagged n v ': xs)) vs++instance MapFieldTree (Just '[]) '[]++-- | MapCons x xs xxs is like  xxs = map (x : ) xs+class MapCons (x :: k) (xs :: [[k]]) (xxs :: [[k]]) | x xs -> xxs+instance MapCons x '[] '[]+instance MapCons x b r => MapCons x (a ': b) ( (x ':  a) ': r)++
+ hlist/Data/HList/FakePrelude.hs view
@@ -0,0 +1,831 @@+{-# LANGUAGE CPP #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Some very basic technology for faking dependent types in Haskell.+-}++module Data.HList.FakePrelude+    (module Data.HList.FakePrelude,+     -- * re-exports+     module Data.Proxy,+     module Data.Tagged,+     Monoid(..),+     Any) where++import Data.Proxy+import Data.Tagged+import GHC.Exts (Constraint,Any)+import GHC.TypeLits+#if __GLASGOW_HASKELL__ >= 800+import qualified GHC.TypeLits as Data.HList.FakePrelude (ErrorMessage((:$$:), (:<>:))) -- XXX check this works?+#endif+#if __GLASGOW_HASKELL__ <= 906+import Control.Applicative+#endif+#if NEW_TYPE_EQ+import Data.Type.Equality (type (==))+#endif++#if !OLD_TYPEABLE+import Data.Typeable+#endif++#if __GLASGOW_HASKELL__ < 709+import Data.Monoid (Monoid(..))+#endif+++-- --------------------------------------------------------------------------+-- * A heterogeneous apply operator++-- | simpler/weaker version where type information only propagates forward+-- with this one. 'applyAB' defined below, is more complicated / verbose to define,+-- but it offers better type inference. Most uses have been converted to+-- 'applyAB', so there is not much that can be done with 'Apply'.+class Apply f a where+  type ApplyR f a :: *+  apply :: f -> a -> ApplyR f a++{- $note++ Polymorphic functions are not first-class in haskell. An example of this+ is:++ > f op = (op (1 :: Double), op (1 :: Int))++ [@RankNTypes@]++ One solution is to enable `-XRankNTypes` and then write a type+ signature which might be `f :: (forall a. Num a => a -> a)`. This+ does not work in the context of HList, since we want to use functions+ that do not necessarily fall into the pattern of (forall a. c a => a -> a).++ [@MultipleArguments@]++ Another solution is to rewrite @op@ to look like++ > f op1 op2 = (op1 (1:: Double), op2 (1 :: Int))++ In some sense this approach works (see HZip), but the result+ is constrained to as many function applications as you are willing to+ write (ex. a function that works for records of six entries would+ look like @hBuild f f f f f f@).+++ [@Defunctionalization@]++ Therefore the selected solution is to write an instance of 'ApplyAB' for a data+ type that takes the place of the original function. In other words,++ > data Fn = Fn+ > instance ApplyAB Fn a b where applyAB Fn a = actual_fn a++ Normally you would have been able to pass around the definition actual_fn.++ [@Type inference / Local functional dependencies@]++ Note that @class ApplyAB@ has three parameters and no functional dependencies.+ Instances should be written in the style:++ > instance (int ~ Int, double ~ Double) => ApplyAB Fn int double+ >  where applyAB _ = fromIntegral++ rather than the more natural++ > instance ApplyAB Fn Int Double++ The first instance allows types to be inferred as if we had+ @class ApplyAB a b c | a -> b c@, while the second instance+ only matches if ghc already knows that it needs+ @ApplyAB Fn Int Double@. Since @applyAB Fn :: Int -> Double@+ has a monomorphic type, this trimmed down example does not+ really make sense because @applyAB (fromIntegral :: Int -> Double)@+ is exactly the same. Nontheless, the other uses of @ApplyAB@+ follow this pattern, and the benefits are seen when the type of+ @applyAB Fn@ has at least one type variable.++ Additional explanation can be found+ in <http://okmij.org/ftp/Haskell/typecast.html#local-fd local functional dependencies>+++ [@AmbiguousTypes@]++ Note that ghc only allows AllowAmbiguousTypes when a type+ signature is provided. Thus expressions such as:++ > data AddJust = AddJust+ > instance (y ~ Maybe x) => ApplyAB AddJust x y where+ >    applyAB _ x = Just x+ >+ > twoJustsBad = hMap AddJust . hMap AddJust -- ambiguous type++ Are not accepted without a type signature that references the+ intermediate \"b\":++ > twoJusts :: forall r a b c. (HMapCxt r AddJust a b, HMapCxt r AddJust b c) =>+ >        r a -> r c+ > twoJusts a = hMap AddJust (hMap AddJust a :: r b)++ An apply class with functional dependencies++ > class ApplyAB' f a b | f a -> b, f b -> a++ Or with equivalent type families++ > class (GetB f a ~ b, GetA f b ~ a) => ApplyAB' f a b++ would not require an annotation for @twoJusts@. However,+ not all instances of ApplyAB will satisfy those functional+ dependencies, and thus the number of classes would proliferate.+ Furthermore, inference does not have to be in one direction+ only, as the example of 'Data.HList.HList.HMap' shows.++-}++-- | No constraints on result and argument types+class ApplyAB f a b where+  applyAB :: f -> a -> b+++{- $fun++ 'Fun' can be used instead of writing a new instance of+ 'ApplyAB'. Refer to the definition/source for the the most+ concise explanation. A more wordy explanation is given below:++ A type signature needs to be provided on 'Fun' to make it work.+ Depending on the kind of the parameters to 'Fun', a number of+ different results happen.+++ [@ex1@]++ A list of kind @[* -> Constraint]@ produces those+ constraints on the argument type:++ >>> :set -XDataKinds+ >>> let plus1f x = if x < 5 then x+1 else 5+ >>> let plus1 = Fun plus1f :: Fun '[Num, Ord] '()+ >>> :t applyAB plus1+ applyAB plus1 :: (Num b, Ord b) => b -> b++ >>> let xs = [1 .. 8]+ >>> map (applyAB plus1) xs == map plus1f xs+ True++ Also note the use of @'()@ to signal that the result+ type is the same as the argument type.+++ A single constraint can also be supplied:++ >>> let succ1 = Fun succ :: Fun Enum '()+ >>> :t applyAB succ1+ applyAB succ1 :: Enum b => b -> b+++ >>> let just = Fun Just :: Fun '[] Maybe+ >>> :t applyAB just+ applyAB just :: a -> Maybe a+++-}+data Fun (cxt :: k1) (getb :: k2)+    = Fun (forall a. FunCxt cxt a => a -> FunApp getb a)++{- | see 'Fun'. The only difference here is that the argument+type is calculated from the result type.++ >>> let rd = Fun' read :: Fun' Read String+ >>> :t applyAB rd+ applyAB rd :: Read b => [Char] -> b++ >>> let fromJust' = Fun' (\(Just a) -> a) :: Fun' '[] Maybe+ >>> :t applyAB fromJust'+ applyAB fromJust' :: Maybe b -> b++Note this use of Fun' means we don't have to get the b out of @Maybe b@,+++-}+data Fun' (cxt :: k1) (geta :: k2)+    = Fun' (forall b. FunCxt cxt b => FunApp geta b -> b)+++type family FunApp (fns :: k) a++type instance FunApp (fn :: *) a = fn+type instance FunApp (fn :: * -> *) a = fn a+type instance FunApp (fn :: ()) a = a++type family FunCxt (cxts :: k) a :: Constraint+type instance FunCxt (x ': xs) a = (x a, FunCxt xs a)+type instance FunCxt (cxt :: * -> Constraint) a = cxt a+type instance FunCxt '[] a = ()+-- | should there be so many ways to write no constraint?+type instance FunCxt (cxt :: ()) a = ()+type instance FunCxt (cxt :: *) a = (cxt ~ a)++instance (FunCxt cxt a, FunApp getb a ~ b)  => ApplyAB (Fun cxt getb) a b where+    applyAB (Fun f) x = f x++instance (FunCxt cxt b, FunApp geta b ~ a)  => ApplyAB (Fun' cxt geta) a b where+    applyAB (Fun' f) x = f x+++++-- ** Simple useful instances of Apply+-- | note this function will only be available at a single type+-- (that is, @hMap succ@ will only work on 'HList' that contain+-- only one type)+instance (x' ~ x, y' ~ y) => ApplyAB (x' -> y') x y where+  applyAB f x = f x++++{- | print. An alternative implementation could be:++>>> let hPrint = Fun print :: Fun Show (IO ())++This produces:++>>> :t applyAB hPrint+applyAB hPrint :: Show a => a -> IO ()++-}+data HPrint = HPrint++instance (io ~ IO (), Show x) => ApplyAB HPrint x io where+  applyAB _ x = print x++++{- | read++>>> applyAB HRead "5.0" :: Double+5.0++-}+data HRead = HRead+instance (String ~ string, Read a) => ApplyAB HRead string a where+    applyAB _ x = read x++-- | show+data HShow = HShow+instance (String ~ string, Show a) => ApplyAB HShow a string where+    applyAB _ x = show x++++++{- | Compose two instances of 'ApplyAB'++>>> applyAB (HComp HRead HShow) (5::Double) :: Double+5.0++-}+data HComp g f = HComp g f -- ^ @g . f@++instance (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where+    applyAB ~(HComp g f) x = applyAB g (applyAB f x :: b)+++{- | @app Comp (f,g) = g . f@. Works like:++>>> applyAB Comp (succ, pred) 'a'+'a'++>>> applyAB Comp (toEnum :: Int -> Char, fromEnum) 10+10++Note that defaulting will sometimes give you the wrong thing++> used to work (with associated types calculating result/argument types)+> >>> applyAB Comp (fromEnum, toEnum) 'a'+> *** Exception: Prelude.Enum.().toEnum: bad argument++-}+data Comp = Comp++instance (y ~ y', fg ~ (x -> y, y' -> z), r ~ (x -> z)) => ApplyAB Comp fg  r+ where+  applyAB _ (f,g) = g . f++-- | (\(a,b) -> f a >> b)+newtype HSeq x = HSeq x+instance (Monad m, ApplyAB f x fx, fx ~ m (), pair ~ (x,m ()),+          ApplyAB f x (m ()) ) => ApplyAB (HSeq f) pair fx where+  applyAB (HSeq f) (x,c) = do asVoid (applyAB f x); c+    where asVoid :: m () -> m ()+          asVoid t = t++++-- | @HJust ()@ is a placeholder for a function that applies the 'HJust' constructor+instance hJustA ~ HJust a => ApplyAB (HJust t) a hJustA where+    applyAB _ a = HJust a+++-- | 'flip'+data HFlip = HFlip++instance (f1 ~ (a -> b -> c), f2 ~ (b -> a -> c))  => ApplyAB HFlip f1 f2 where+    applyAB _ = flip+++-- | 'fmap'+newtype HFmap f = HFmap f++instance (x ~ t a,+          y ~ t b,+          Functor t,+          ApplyAB f a b) =>+  ApplyAB (HFmap f) x y where+    applyAB (HFmap f) = fmap (applyAB f)+++-- | 'liftA2'+newtype LiftA2 f = LiftA2 f++instance (ApplyAB f (x,y) z,+          mz ~ m z,+          mxy ~ (m x, m y),+          Applicative m) => ApplyAB (LiftA2 f) mxy mz where+    applyAB (LiftA2 f) xy = liftA2 (curry (applyAB f)) `uncurry` xy+++-- | 'untag'+data HUntag = HUntag+instance (Tagged t x ~ tx) => ApplyAB HUntag tx x where+    applyAB _ (Tagged x) = x+++-- --------------------------------------------------------------------------+-- * Proxy+--++-- $note see "Data.Proxy"++-- | A special 'Proxy' for record labels, polykinded+data Label l = Label++labelToProxy :: Label l -> Proxy l+labelToProxy _ = Proxy++class ShowLabel l where+  showLabel :: Label l -> String+++-- --------------------------------------------------------------------------++-- * Booleans++{- $boolNote++GHC already lifts booleans, defined as++> data Bool = True | False++to types: Bool becomes kind and True and False (also denoted by+'True and 'False) become nullary type constructors.++The above line is equivalent to++> data HTrue+> data HFalse++> class HBool x+> instance HBool HTrue+> instance HBool HFalse++-}++-- ** Value-level proxies+hTrue  :: Proxy True ; hTrue  = Proxy+hFalse :: Proxy False; hFalse = Proxy+++-- **  Conjunction++type family HAnd (t1 :: Bool) (t2 :: Bool) :: Bool+type instance HAnd False t  = False+type instance HAnd True  t  = t++-- | `demote' to values+hAnd :: Proxy t1 -> Proxy t2 -> Proxy (HAnd t1 t2)+hAnd _ _ = Proxy+++-- ** Disjunction++type family HOr (t1 :: Bool) (t2 :: Bool) :: Bool+type instance HOr False t    = t+type instance HOr True t     = True++-- | `demote' to values+hOr :: Proxy t1 -> Proxy t2 -> Proxy (HOr t1 t2)+hOr _ _ = Proxy++{- $boolHistoricalNote++Compare with the original code based on functional dependencies:++> 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++> instance HOr HTrue HFalse HTrue+>  where+>   hOr _ _ = hTrue++> instance HOr HFalse HTrue HTrue+>  where+>   hOr _ _ = hTrue++> instance HOr HTrue HTrue HTrue+>  where+>   hOr _ _ = hTrue+-}++type family HNot (x :: Bool) :: Bool+type instance HNot True = False+type instance HNot False = True++-- | as compared with 'HNot' this version is injective+class HNotFD (b :: Bool) (nb :: Bool) | b -> nb, nb -> b+instance HNotFD True False+instance HNotFD False True++hNot :: HNotFD a notA => Proxy a -> Proxy notA+hNot _ = Proxy+++class HCond (t :: Bool) x y z | t x y -> z+ where+  hCond :: Proxy t -> x -> y -> z++instance HCond False x y y+ where+  hCond _ _ y = y++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++-- | The data type to be lifted to the type level+data HNat = HZero | HSucc HNat+++hZero :: Proxy HZero; hZero = Proxy+hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = Proxy+hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = Proxy++class HNat2Integral (n::HNat) where+    hNat2Integral :: Integral i => Proxy n -> i++type family HNat2Nat (n :: HNat) :: Nat+type instance HNat2Nat HZero = 0+type instance HNat2Nat (HSucc n) = 1 + HNat2Nat n++#if MIN_VERSION_base(4,7,0)+{- Instead convert HNat to GHC.TypeLits.'Nat' with 'HNat2Nat' and use functions+from that module to produce the 'Integer' -}+instance KnownNat (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (natVal (Proxy :: Proxy (HNat2Nat n)))+#else+{- doesn't work: gives "No instance for (SingI Nat (1 + (1 + 0)))"+instance SingI (HNat2Nat n) => HNat2Integral n where+    hNat2Integral _ = fromIntegral (fromSing (sing :: Sing (HNat2Nat n)))+-}++-- | a slow (at runtime) implementation for ghc 7.6:+instance HNat2Integral HZero where+    hNat2Integral _ = 0++instance HNat2Integral n => HNat2Integral (HSucc n) where+    hNat2Integral n = hNat2Integral (hPred n) + 1+#endif+++class HNats2Integrals (ns :: [HNat]) where+    hNats2Integrals :: Integral i => Proxy ns -> [i]++instance HNats2Integrals '[] where+    hNats2Integrals _ = []++instance (HNats2Integrals ns,+          HNat2Integral n)+  => HNats2Integrals (n ': ns) where+    hNats2Integrals _ = hNat2Integral (Proxy :: Proxy n) :+                        hNats2Integrals (Proxy :: Proxy ns)++++-- | Equality on natural numbers+-- (eventually to be subsumed by the universal polykinded HEq)+type family HNatEq (t1 :: HNat) (t2 :: HNat) :: Bool+type instance HNatEq HZero HZero          = True+type instance HNatEq HZero (HSucc n)      = False+type instance HNatEq (HSucc n) HZero      = False+type instance HNatEq (HSucc n) (HSucc n') = HNatEq  n n'+++-- | Less than++type family HLt (x :: HNat) (y :: HNat) :: Bool++type instance HLt HZero HZero          = False+type instance HLt HZero (HSucc n)      = True+type instance HLt (HSucc n) HZero      = False+type instance HLt (HSucc n) (HSucc n') = HLt  n n'++hLt :: Proxy x -> Proxy y -> Proxy (HLt x y)+hLt _ _ = Proxy+++-- | Less than or equal to+type family HLe (x :: HNat) (y :: HNat) :: Bool++type instance HLe HZero HZero          = True+type instance HLe (HSucc x) y          = HLt x y++hLe :: Proxy x -> Proxy y -> Proxy (HLe x y)+hLe _ _ = Proxy++-- | @HDiv2 x@ behaves like @x `div` 2@+type family HDiv2 (x :: HNat) :: HNat+type instance HDiv2 HZero = HZero+type instance HDiv2 (HSucc HZero) = HZero+type instance HDiv2 (HSucc (HSucc a)) = HSucc (HDiv2 a)++++-- --------------------------------------------------------------------------+-- * Maybies+-- $maybiesNote We cannot use lifted Maybe since the latter are not populated++data    HNothing  = HNothing  deriving Show+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 for types that may have different kinds. This definition+-- allows operations on @Record [Tagged \"x\" a, Tagged 2 b]@ to work+-- as expected.+type HEqK (x :: k1) (y :: k2) (b :: Bool) = HEq (Proxy x) (Proxy y) b++#if NEW_TYPE_EQ+-- | Uses @(==) :: * -> * -> Bool@ because+-- there is no polykinded instance of (==),+-- since that one overlaps "more productive"+-- instances that pattern match on types.+instance ((Proxy x == Proxy y) ~ b) => HEq x y b+#endif++hEq :: HEq x y b => x -> y -> Proxy b+hEq _ _ = Proxy+++-- | this class generalizes HEq by allowing the choice of @f@ to allow+-- equating only part of x and y+class HEqByFn f => HEqBy (f :: t) (x :: k) (y :: k) (b :: Bool) | f x y -> b+++++-- | Every instance of this class should have an instance of 'HEqBy'+class HEqByFn f++-- * Arity++type Arity f n = (ArityFwd f n, ArityRev f n)++-- | calculate the number of arguments a function can take+class ArityFwd (f :: *) (n :: HNat) | f -> n+++-- | given the number of arguments a function can take, make sure+-- the function type actually matches+class ArityRev (f :: *) (n :: HNat) -- n -> f -- if we had -XDysfunctionalDependencies++instance ArityRev f HZero+instance (xf ~ (x -> f), ArityRev f n) => ArityRev xf (HSucc n)+++-- --------------------------------------------------------------------------++-- * Staged equality+-- |+--+--  * Establish type equality statically+--+--  * Establish remaining value-level equality dynamically+--+-- removed: use typeable+++-- --------------------------------------------------------------------------+-- * Type-safe cast -- no longer need. We use a a ~ b+++-- * Cast++-- | Named after 'Data.Typeable.cast', which behaves the same at runtime.+-- One difference is that there is a HCast instance for every type, while+-- 'Typeable' instances can be missing sometimes.++class HCast x y where+    hCast :: x -> Maybe y++instance (HEq x y b, HCast1 b x y) => HCast x y where+    hCast = hCast1 (Proxy :: Proxy b)++-- | helper for 'HCast'+class HCast1 (b :: Bool) x y where+    hCast1 :: Proxy b -> x -> Maybe y++instance (x ~ y) => HCast1 True x y where+    hCast1 _ x = Just x++instance HCast1 False x y where+    hCast1 _ _ = Nothing+++++-- --------------------------------------------------------------------------++-- * Error messages++{- | A class without instances for explicit failure.++Note that with ghc>=8.0, `x :: TypeError` which is formatted properly.+Otherwise `x` is made of nested (left-associated) promoted tuples.+For example:++> (x ~ '( '( '("the", Int), "is wrong") ) ) :: ((,) Symbol *, Symbol)++Therefore code that works across ghc-7.6 through ghc-8.0 needs to+use ErrText, ErrShowType, :<>:, :$$: to construct the type x.  -}+class Fail (x :: k)++#if __GLASGOW_HASKELL__ >= 800+-- | use the alias ErrText to prevent conflicts with Data.Text+--+-- GHC.TypeLits.:<>: and GHC.TypeLits.:$$: are re-exported+type ErrText x = GHC.TypeLits.Text x+type ErrShowType x = GHC.TypeLits.ShowType x++-- type Fail = TypeError -- another option+instance TypeError x => Fail x+#else++type ErrText x = x+type ErrShowType x = x+type x :<>: y = '(x,y)+type x :$$: y = '(x,y)+infixl 6 :<>:+infixl 5 :$$:+#endif++-- ** Error messages used elsewhere+type FieldNotFound key collection = ErrText "key" :<>: ErrShowType key+      :$$: ErrText "could not be found in" :<>: ErrShowType collection++type ExcessFieldFound key collection = ErrText "found field" :<>: ErrShowType key+      :$$: ErrText "when it should be absent from" :<>: ErrShowType collection++type HNatIndexTooLarge (nat :: HNat) (r :: [k] -> *) (xs :: [k]) =+      ErrText "0-based index" :<>: ErrShowType (HNat2Nat nat) :<>:+      ErrText "is too large for collection"+            :$$: ErrShowType (r xs)+    -- :$$: ErrText "(length: " :<>: ErrShowType (HNat2Nat (HLength collection)) :<>: ErrText " )"+    -- Data.HList.HList.HLength isn't available here++type ExtraField x = ErrText "extra field" :<>: ErrShowType x+++#if OLD_TYPEABLE+type TypeablePolyK a = (() :: Constraint)+#else+type TypeablePolyK (a :: k) = Typeable a+#endif++-- * Constraining Lists+-- ** Length++-- | Ensure two lists have the same length. We do case analysis on the+-- first one (hence the type must be known to the type checker).+-- In contrast, the second list may be a type variable.+class SameLength' (es1 :: [k]) (es2 :: [m])+instance (es2 ~ '[]) => SameLength' '[] es2+instance (SameLength' xs ys, es2 ~ (y ': ys)) => SameLength' (x ': xs) es2++{- | symmetrical version of 'SameLength''. Written as a class instead of++ > type SameLength a b = (SameLength' a b, SameLength' b a)++since ghc expands type synonyms, but not classes (and it seems to have the same+result)++-}+class (SameLength' x y, SameLength' y x) =>+        SameLength (x :: [k]) (y :: [m]) where++  {- | @SameLength x y => Equality (r x) (q y) (r x) (q y)@++  used like 'Control.Lens.simple', except it restricts+  the type-level lists involved to have the same length,+  without fixing the type of container or the elements+  in the list.+  -}+  sameLength :: r x `p` f (q y) -> r x `p` f (q y)+  sameLength = id++-- | 'asTypeOf'+asLengthOf :: SameLength x y => r x -> s y -> r x+asLengthOf = const+++instance (SameLength' x y, SameLength' y x) => SameLength x y++type family SameLengths (xs :: [[k]]) :: Constraint+type instance SameLengths (x ': y ': ys) = (SameLength x y, SameLengths (y ': ys))+type instance SameLengths '[] = ()+type instance SameLengths '[x] = ()++-- ** Labels++class SameLabels (x :: k) (y :: m)++{- | @sameLabels@ constrains the type of an optic, such that the labels+   (@t@ in @Tagged t a@) are the same. @x@ or @y@ may have more elements+   than the other, in which case the elements at the end+   of the longer list do not have their labels constrained.++   see also 'sameLength'+-}+sameLabels :: SameLabels x y => p (r x) (f (q y)) -> p (r x) (f (q y))+sameLabels = id++-- instances for [*] kind+instance SameLabels '[] '[]+instance SameLabels '[] (x ': xs)+instance SameLabels (x ': xs) '[]+instance (SameLabels x y, SameLabels xs ys) =>+  SameLabels (x ': xs) (y ': ys)+++instance (Label t ~ Label t') => SameLabels (Label t) (Tagged t' a)+instance (Label t ~ Label t') => SameLabels (Label t) (Label t')+instance (Label t ~ Label t') => SameLabels (Label t) (t' :: Symbol)++instance SameLabels (Label t) s => SameLabels (t :: Symbol) s+instance SameLabels (Label t) s => SameLabels (Tagged t a) s++-- ** A list has only Tagged values++-- | The 'Record', 'Variant', 'TIP', 'TIC' type constructors only make+-- sense when they are applied to an instance of this class+class HAllTaggedLV (ps :: [*])+instance HAllTaggedLV '[]+instance (HAllTaggedLV xs, x ~ Tagged t v) => HAllTaggedLV (x ': xs)+++-- | see Data.HList.Record.'zipTagged'+type family ZipTagged (ts :: [k]) (vs :: [*]) :: [*]+type instance ZipTagged (Label t ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs+type instance ZipTagged ((t :: Symbol) ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs+type instance ZipTagged '[] '[] = '[]
+ hlist/Data/HList/HArray.hs view
@@ -0,0 +1,225 @@++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Array-like access to HLists.+ -}++module Data.HList.HArray where++import Data.HList.FakePrelude+import Data.HList.HList+++-- --------------------------------------------------------------------------+-- * Lookup++class HLookupByHNat (n :: HNat) (l :: [*]) where+  type HLookupByHNatR (n :: HNat) (l :: [*]) :: *+  hLookupByHNat :: Proxy n -> HList l -> HLookupByHNatR n l++instance HLookupByHNat HZero (e ': l) where+  type HLookupByHNatR HZero (e ': l) = e+  hLookupByHNat _ (HCons e _)        = e++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 HDeleteAtHNat (n :: HNat) (l :: [*]) where+  type HDeleteAtHNatR (n :: HNat) (l :: [*]) :: [*]+  hDeleteAtHNat :: Proxy n -> HList l -> HList (HDeleteAtHNatR n l)++instance HDeleteAtHNat HZero (e ': l) where+  type HDeleteAtHNatR  HZero (e ': l) = l+  hDeleteAtHNat _ (HCons _ l)         = l++instance HDeleteAtHNat n l => HDeleteAtHNat (HSucc n) (e ': l) where+  type HDeleteAtHNatR  (HSucc n) (e ': l) = e ': (HDeleteAtHNatR n l)+  hDeleteAtHNat n (HCons e l) = HCons e (hDeleteAtHNat (hPred n) l)+++-- --------------------------------------------------------------------------+-- * Update+class HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where+    hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l)++instance HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where+    hUpdateAtHNat = hUpdateAtHNat' (Proxy :: Proxy l)++class HUpdateAtHNat' (n :: HNat) e (l :: [*]) (l0 :: [*]) where+  type HUpdateAtHNatR (n :: HNat) e (l :: [*]) :: [*]+  hUpdateAtHNat' :: Proxy l0 -> Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l)++instance HUpdateAtHNat' HZero e1 (e ': l) l0 where+  type HUpdateAtHNatR  HZero e1 (e ': l) = e1 ': l+  hUpdateAtHNat' _ _ e1 (HCons _ l)      = HCons e1 l++instance HUpdateAtHNat' n e1 l l0 => HUpdateAtHNat' (HSucc n) e1 (e ': l) l0 where+  type HUpdateAtHNatR  (HSucc n) e1 (e ': l) = e ': (HUpdateAtHNatR n e1 l)+  hUpdateAtHNat' l0 n e1 (HCons e l) = HCons e (hUpdateAtHNat' l0 (hPred n) e1 l)++instance Fail (HNatIndexTooLarge n HList l0) => HUpdateAtHNat' n e1 '[] l0 where+  type HUpdateAtHNatR n e1 '[] = '[]+  hUpdateAtHNat' _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances"++-- --------------------------------------------------------------------------+-- * Projection++-- One way of implementing it:++hProjectByHNats' ns l = hMap (FHLookupByHNat l) ns++newtype FHLookupByHNat (l :: [*]) = FHLookupByHNat (HList l)++instance HLookupByHNat n l =>+    Apply (FHLookupByHNat l) (Proxy (n :: HNat)) where+  type ApplyR (FHLookupByHNat l) (Proxy n) = HLookupByHNatR n l+  apply (FHLookupByHNat l) n               = hLookupByHNat  n l++-- The drawback is that the list ns must be a constructed value.+-- We cannot lazily pattern-match on GADTs. Moreover, there are+-- repeated traversals of the HList l at run-time.++-- 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.++hProjectByHNats (_ :: Proxy (ns :: [HNat])) l =+    hUnfold (FHUProj :: FHUProj True ns) (l,hZero)++data FHUProj (sel :: Bool) (ns :: [HNat]) = FHUProj++instance Apply (FHUProj sel ns) (HList '[],n) where+    type ApplyR (FHUProj sel ns) (HList '[],n) = HNothing+    apply _ _ = HNothing++instance (ch ~ Proxy (HBoolEQ sel (KMember n ns)),+          Apply (ch, FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat))) =>+    Apply (FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat)) where+    type ApplyR (FHUProj sel ns) (HList (e ': l),Proxy n) =+       ApplyR (Proxy (HBoolEQ sel (KMember n ns)), FHUProj sel ns)+              (HList (e ': l),Proxy n)+    apply fn s = apply (Proxy::ch,fn) s++instance Apply (Proxy True, FHUProj sel ns)+               (HList (e ': l),Proxy (n::HNat)) where+    type ApplyR (Proxy True, FHUProj sel ns) (HList (e ': l),Proxy n) =+        (HJust (e, (HList l,Proxy (HSucc n))))+    apply _ (HCons e l,n) = (HJust (e,(l,hSucc n)))++instance (Apply (FHUProj sel ns) (HList l, Proxy (HSucc n))) =>+    Apply (Proxy False, FHUProj sel ns)+          (HList (e ': l),Proxy (n::HNat)) where+    type ApplyR (Proxy False, FHUProj sel ns) (HList (e ': l),Proxy n) =+        ApplyR (FHUProj sel ns) (HList l, Proxy (HSucc n))+    apply (_,fn) (HCons _ l,n) = apply fn (l,hSucc n)+++-- 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)++type HProjectByHNatsCtx ns l =+  (Apply (FHUProj True ns) (HList l, Proxy 'HZero),+      HUnfold' (FHUProj True ns)+       (HList l, Proxy 'HZero)+    )++-- * Complement of Projection++-- 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.++hProjectAwayByHNats (_ :: Proxy (ns :: [HNat])) l =+    hUnfold (FHUProj :: FHUProj False ns) (l,hZero)+++-- Useful abbreviations for complex types (which are inferred)+type HProjectAwayByHNatsR (ns :: [HNat]) (l :: [*]) =+    HUnfold (FHUProj False ns) (HList l, Proxy 'HZero)++type HProjectAwayByHNatsCtx ns l =+  (Apply (FHUProj False ns) (HList l, Proxy 'HZero),+      HUnfold' (FHUProj False ns) (HList l, Proxy 'HZero)+  )++-- * Splitting+-- | Splitting an array according to indices++-- The following is not optimal; we'll optimize later if needed++hSplitByHNats ns l = (hProjectByHNats ns l,+                      hProjectAwayByHNats ns l)+{-+hSplitByHNats ns l = hSplitByHNats' ns (hFlag l)++class HNats ns => HSplitByHNats' ns l l' l'' | ns l -> l' l''+ where+  hSplitByHNats' :: ns -> l -> (l',l'')++instance HSplit l l' l''+      => HSplitByHNats' HNil l HNil l'+ where+  hSplitByHNats' HNil l = (HNil,l')+   where+    (l',_) = hSplit 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'''+-}+++{-++-- --------------------------------------------------------------------------+-- * Bounded lists++class HMaxLength l s+instance (HLength l s', HLt s' (HSucc s) HTrue) => HMaxLength l s++class HMinLength l s+instance (HLength l s', HLt s (HSucc s') HTrue) => HMinLength l s++class HSingleton l+instance HLength l (HSucc HZero) => HSingleton l++hSingle :: (HSingleton l, HHead l e) => l -> e+hSingle = hHead++-}
+ hlist/Data/HList/HCurry.hs view
@@ -0,0 +1,72 @@+{- |++ Description : curry / uncurry++ Convert between functions taking HLists and functions taking many arguments++-}+module Data.HList.HCurry where++import Data.HList.FakePrelude+import Data.HList.HList+import Data.HList.TypeEqO () -- Arity instance++{- | 'curry'/'uncurry' for many arguments and HLists instead of tuples++XXX the last FD @xs -> n@ is needed to make hCompose infer the right types:+arguably it shouldn't be needed++-}+class HLengthEq xs n => HCurry' (n :: HNat) f xs r+          | f xs -> r, r xs -> f, n f -> xs, xs -> n where+    hUncurry' :: Proxy n -> f -> HList xs -> r+    hCurry' :: Proxy n -> (HList xs -> r) -> f++instance HCurry' HZero b '[] b where+    hUncurry' _ b _ = b+    hCurry' _ f = f HNil++instance (HCurry' n b xs r) => HCurry' (HSucc n) (x -> b) (x ': xs) r where+    hUncurry' n f (HCons x xs) = hUncurry' (hPred n) (f x) xs+    hCurry' n f x = hCurry' (hPred n) (f . HCons x)++hUncurry f = hUncurry' (arityOf f) f++-- | Note: with ghc-7.10 the Arity constraint added here does not work+-- properly with hCompose, so it is possible that other uses of 'hCurry'+-- are better served by @hCurry' Proxy@.+hCurry f = let f' = hCurry' (arityOf f') f+           in f'++{- | compose two functions that take multiple arguments. The result of the+second function is the first argument to the first function. An example is+probably clearer:++>>> let f = hCompose (,,) (,)+>>> :t f+f :: ... -> ... -> ... -> ... -> ((..., ...), ..., ...)++>>> f 1 2 3 4+((1,2),3,4)++Note: polymorphism can make it confusing as to how many parameters a function+actually takes. For example, the first two ids are @id :: (a -> b) -> (a -> b)@ in++>>> (.) id id id 'y'+'y'++>>> hCompose id id id 'y'+'y'++still typechecks, but in that case @hCompose i1 i2 i3 x == i1 ((i2 i3) x)@+has id with different types than @(.) i1 i2 i3 x == (i1 (i2 i3)) x++Prompted by <http://stackoverflow.com/questions/28932054/can-hlistelim-be-composed-with-another-function>++-}+hCompose f g = hCurry' Proxy $ \xs -> case hSplitAt Proxy xs of+        (xg,xf) -> hUncurry f (hUncurry g xg `HCons` xf)+++arityOf :: Arity f n => f -> Proxy n+arityOf _ = Proxy
+ hlist/Data/HList/HList.hs view
@@ -0,0 +1,1657 @@+{-# LANGUAGE CPP #-}+{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Basic declarations for typeful heterogeneous lists.++ -}++module Data.HList.HList where++import Data.HList.FakePrelude+import Data.HList.HListPrelude++import Text.ParserCombinators.ReadP+import Data.List++import LensDefs++import Data.Array (Ix)++#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup+#endif++-- --------------------------------------------------------------------------+-- * Heterogeneous type sequences+{- $note++There are three sensible ways to define HLists:++@+data HList (l::[*]) where+    HNil  :: HList '[]+    HCons :: e -> HList l -> HList (e ': l)+@++This ensures that sequences can only be formed with Nil+and Cons. The argument to HList is a promoted lists (kind @[*]@),+which has a more attractive syntax.+++Earlier versions of HList used an algebraic data type:++@+data HCons a b = HCons a b+data HNil = HNil+@++Disadvantages:++* values with types like @HCons Int Double@ to be created,+  which are nonsense to the functions in HList++* some recursive functions do not need a class with the GADT. For example:++  @+    hInit :: HListGADT (x ': xs) -> HListGADT (HInit (x ': xs))+    hInit (HCons x xs@(HCons _ _)) = HCons x (hInit xs)+    hInit (HCons _ HNil) = HNil++    type family HInit (xs :: [k]) :: [k]+  @++  but without the GADT, 'hInit' is written as in a class,+  which complicates inferred types+++Advantages++* lazy pattern matches are allowed, so lazy pattern matching+  on a value @undefined :: HList [a,b,c]@ can create the+  spine of the list. 'hProxies' avoids the use of 'undefined',+  but a slightly more complicated class context has to be written+  or inferred.++* type inference is better if you want to directly pattern match+<http://stackoverflow.com/questions/19077037/is-there-any-deeper-type-theoretic-reason-ghc-cant-infer-this-type see stackoverflow post here>++* better pattern exhaustiveness checking (as of ghc-7.8)++* standalone deriving works++* Data.Coerce.coerce works because the parameters have role representational,+  not nominal as they are for the GADT and data family. Probably the GADT/type+  family actually do have a representational role:+  <http://stackoverflow.com/questions/24222552/does-this-gadt-actually-have-type-role-representational>++++The data family version (currently used) gives the same type constructor+@HList :: [*] -> *@ as the GADT, while pattern matching behaves+like the algebraic data type. Furthermore, nonsense values like+@HCons 1 2 :: HCons Int Int@ cannot be written with the data family.++A variation on the data family version is++> data instance HList '[] = HNil+> newtype instance HList (x ': xs) = HCons1 (x, HList xs)+> pattern HCons x xs = HCons1 (x, xs)++This allows HList to have a nominal role, but on the other+hand the PatternSynonym is not supported with ghc-7.6 and+exhaustiveness checking is not as good (warnings for _ being+unmatched)++-}+++data family HList (l::[*])++data instance HList '[] = HNil+data instance HList (x ': xs) = x `HCons` HList xs++deriving instance Eq (HList '[])+deriving instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs))++deriving instance Ord (HList '[])+deriving instance (Ord x, Ord (HList xs)) => Ord (HList (x ': xs))++deriving instance Ix (HList '[])+deriving instance (Ix x, Ix (HList xs)) => Ix (HList (x ': xs))++deriving instance Bounded (HList '[])+deriving instance (Bounded x, Bounded (HList xs)) => Bounded (HList (x ': xs))+++-- Enum cannot be derived+++-- | creates a HList of Proxies++class HProxiesFD (xs :: [*]) pxs | pxs -> xs -- DropProxy pxs ~ xs+                      , xs -> pxs -- AddProxy xs ~ pxs+      where hProxies :: HList pxs++{- Ideally we could write:++> class DropProxy (AddProxy xs) ~ xs => HProxies xs where+>     hProxies :: HList (AddProxy xs)++See https://ghc.haskell.org/trac/ghc/ticket/10009 -}+type HProxies xs = HProxiesFD xs (AddProxy xs)+++{- | Add 'Proxy' to a type++>>> let x = undefined :: HList (AddProxy [Char,Int])+>>> :t x+x :: HList '[Proxy Char, Proxy Int]+++-}+type family AddProxy (xs :: k) :: k+type instance AddProxy '[] = '[]+type instance AddProxy (x ': xs) = AddProxy x ': AddProxy xs+type instance AddProxy (x :: *) = Proxy x++-- | inverse of 'AddProxy'+type family DropProxy (xs :: k) :: k+type instance DropProxy (x ': xs) = DropProxy x ': DropProxy xs+type instance DropProxy '[] = '[]+type instance DropProxy (Proxy x) = x++instance HProxiesFD '[] '[] where+    hProxies = HNil++instance (HProxiesFD xs pxs) => HProxiesFD (x ': xs) (Proxy x ': pxs) where+    hProxies = Proxy `HCons` hProxies++++instance Show (HList '[]) where+    show _ = "H[]"++instance (Show e, Show (HList l)) => Show (HList (e ': l)) where+    show (HCons x l) =+      case show l of+        'H':'[':s -> "H[" ++ show x ++ (if s == "]" then s else "," ++ s)+        s -> error $ "unreachable branch: " ++ show x ++ " " ++ s++instance Read (HList '[]) where+    readsPrec _ str = case stripPrefix "H[]" str of+                        Nothing -> []+                        Just rest -> [(HNil, rest)]++instance+   (HProxies l, Read e,+    HSequence ReadP (ReadP e ': readP_l) (e ': l),+    HMapCxt HList ReadElement (AddProxy l) readP_l)  =>+      Read (HList (e ': l)) where+  readsPrec _ = readP_to_S $ do+    _ <- string "H["+    l <- return (hProxies :: HList (AddProxy l))+    let parsers = readS_to_P reads `HCons` hMap ReadElement l+    hlist <- hSequence parsers+    _ <- string "]"+    return hlist+++-- similar to ReadComponent used to define instance Read Record+data ReadElement = ReadElement++instance (y ~ ReadP x, Read x) => ApplyAB ReadElement (Proxy x) y where+    applyAB ReadElement _ = do+      _ <- string ","+      readS_to_P reads+++infixr 2 `HCons`+++-- --------------------------------------------------------------------------+-- * Basic list functions++-- | 'head'+hHead :: HList (e ': l) -> e+hHead (HCons x _) = x++-- | 'tail'+hTail :: HList (e ': l) -> HList l+hTail (HCons _ l) = l++-- | 'last'+hLast xs = hHead (hReverse_ xs)+++class HInit xs where+    type HInitR xs :: [*]+    hInit :: HList xs -> HList (HInitR xs)++instance HInit '[x] where+    type HInitR '[x] = '[]+    hInit _ = HNil++instance HInit (b ': c) => HInit (a ': b ': c) where+    type HInitR (a ': b ': c) = a ': HInitR (b ': c)+    hInit (a `HCons` bc) = a `HCons` hInit bc+++-- | Length, but see 'HLengthEq' instead+type family HLength (x :: [k]) :: HNat+type instance HLength '[] = HZero+type instance HLength (x ': xs) = HSucc (HLength xs)++hLength   :: HLengthEq l n => HList l -> Proxy n+hLength _ =  Proxy++-- ** Append+instance HExtend e (HList l) where+  type HExtendR e (HList l) = HList (e ': l)+  (.*.) = HCons++instance HAppendList l1 l2 => HAppend (HList l1) (HList l2) where+  hAppend = hAppendList+type instance HAppendR (HList l1) (HList l2) = HList (HAppendListR l1 l2)++type family HAppendListR (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HAppendListR '[] l = l+type instance HAppendListR (e ': l) l' = e ': HAppendListR l l'+++class HAppendList l1 l2 where+  -- | the same as 'hAppend'+  hAppendList :: HList l1 -> HList l2 -> HList (HAppendListR l1 l2)++instance HAppendList '[] l2 where+  hAppendList HNil l = l++instance HAppendList l l' => HAppendList (x ': l) l' where+  hAppendList (HCons x l) l' = HCons x (hAppendList l l')++-- --------------------------------------------------------------------------++-- ** Alternative append+++-- | 'hAppend'' below is implemented using the same idea+append' :: [a] -> [a] -> [a]+append' l l' = foldr (:) l' l++-- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr'+hAppend' :: (HFoldr FHCons v l r) => HList l -> v -> r+hAppend' l l' = hFoldr FHCons l' l++data FHCons = FHCons++instance ( x ~ (e,HList l), y ~ (HList (e ': l))) => ApplyAB FHCons x y  where+    applyAB _ (e,l) = HCons e l+++-- ** Historical append++{- $++The original HList code is included below. In both cases+we had to program the algorithm twice, at the term and the type levels.++[@The class HAppend@]++> class HAppend l l' l'' | l l' -> l''+>  where+>   hAppend :: l -> l' -> l''+>++[@The instance following the normal append@]++> instance HList l => HAppend HNil l l+>  where+>   hAppend HNil l = l+>+> instance (HList l, HAppend l l' l'')+>       => HAppend (HCons x l) l' (HCons x l'')+>  where+>   hAppend (HCons x l) l' = HCons x (hAppend l l')++-}++-- --------------------------------------------------------------------------+-- * Reversing HLists++-- Append the reversed l1 to l2+type family HRevAppR (l1 :: [k]) (l2 :: [k]) :: [k]+type instance HRevAppR '[] l = l+type instance HRevAppR (e ': l) l' = HRevAppR l (e ': l')+++class HRevApp l1 l2 l3 | l1 l2 -> l3 where+    hRevApp :: HList l1 -> HList l2 -> HList l3++instance HRevApp '[] l2 l2 where+    hRevApp _ l = l++instance HRevApp l (x ': l') z => HRevApp (x ': l) l' z where+    hRevApp (HCons x l) l' = hRevApp l (HCons x l')++++class HReverse xs sx | xs -> sx, sx -> xs where+    hReverse :: HList xs -> HList sx++instance (HRevApp xs '[] sx,+          HRevApp sx '[] xs) => HReverse xs sx where+    hReverse l = hRevApp l HNil++-- | a version of 'hReverse' that does not allow the type+-- information to flow backwards+hReverse_ l = hRevApp l HNil++-- --------------------------------------------------------------------------++--+-- * A nicer notation for lists+--+++-- | List termination+hEnd :: HList l -> HList l+hEnd = id++{- ^+   Note:++        [@x :: HList a@] means: @forall a. x :: HList a@++        [@hEnd x@] means: @exists a. x :: HList a@+-}+++-- |  Building lists++hBuild :: (HBuild' '[] r) => r+hBuild =  hBuild' HNil++class HBuild' l r where+    hBuild' :: HList l -> r++instance HReverse l l'+      => HBuild' l (HList l') where+  hBuild' l = hReverse l++instance HBuild' (a ': l) r+      => HBuild' l (a->r) where+  hBuild' l x = hBuild' (HCons x l)++-- ** examples+{- $examplesNote++The classes above allow the third (shortest) way to make a list+(containing a,b,c) in this case++> list = a `HCons` b `HCons` c `HCons` HNil+> list = a .*. b .*. c .*. HNil+> list = hEnd $ hBuild a b c++>>> let x = hBuild True in hEnd x+H[True]++>>> let x = hBuild True 'a' in hEnd x+H[True,'a']++>>> let x = hBuild True 'a' "ok" in hEnd x+H[True,'a',"ok"]++hBuild can also produce a Record, such that++> hBuild x y ^. from unlabeled++can also be produced using++@+'hEndR' $ hBuild x y+@++-}++-- *** historical+{- $hbuild the show instance has since changed, but these uses of+'hBuild'/'hEnd' still work++> HList> let x = hBuild True in hEnd x+> HCons True HNil++> HList> let x = hBuild True 'a' in hEnd x+> HCons True (HCons 'a' HNil)++> HList> let x = hBuild True 'a' "ok" in hEnd x+> HCons True (HCons 'a' (HCons "ok" HNil))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5))+> HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil)))++> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus+> True++-}++-- --------------------------------------------------------------------------++-- * folds+-- ** foldr+-- $foldNote  Consume a heterogenous list.+++class HFoldr f v (l :: [*]) r where+    hFoldr :: f -> v -> HList l -> r++instance (v ~ v') => HFoldr f v '[] v' where+    hFoldr       _ v _   = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr f v l r)+    => HFoldr f v (e ': l) r' where+    hFoldr f v (HCons x l)    = applyAB f (x, hFoldr f v l :: r)+++class HScanr f z ls rs where+    hScanr :: f -> z -> HList ls -> HList rs++instance lz ~ '[z] => HScanr f z '[] lz where+    hScanr _ z _ = HCons z HNil++instance (ApplyAB f (x,r) s, HScanr f z xs (r ': rs),+          srrs ~ (s ': r ': rs)) => HScanr f z (x ': xs) srrs where+    hScanr f z (HCons x xs) =+        case hScanr f z xs :: HList (r ': rs) of+            HCons r rs -> (applyAB f (x,r) :: s) `HCons` r `HCons` rs++class HFoldr1 f (l :: [*]) r where+    hFoldr1 :: f -> HList l -> r++instance (v ~ v') => HFoldr1 f '[v] v' where+    hFoldr1      _ (HCons v _)  = v++-- | uses 'ApplyAB' not 'Apply'+instance (ApplyAB f (e, r) r', HFoldr1 f (e' ': l) r)+    => HFoldr1 f (e ': e' ': l) r' where+    hFoldr1 f (HCons x l)    = applyAB f (x, hFoldr1 f l :: r)+++-- ** foldl++{- | like 'foldl'+++>>> hFoldl (uncurry $ flip (:)) [] (1 `HCons` 2 `HCons` HNil)+[2,1]+++-}+class HFoldl f (z :: *) xs (r :: *) where+    hFoldl :: f -> z -> HList xs -> r++instance (zx ~ (z,x), ApplyAB f zx z', HFoldl f z' xs r)+    => HFoldl f z (x ': xs) r where+    hFoldl f z (x `HCons` xs) = hFoldl f (applyAB f (z,x) :: z') xs++instance (z ~ z') => HFoldl f z '[] z' where+    hFoldl _ z _ = z++++++-- * unfolds++-- ** unfold+-- $unfoldNote Produce a heterogenous list. Uses the more limited+-- 'Apply' instead of 'App' since that's all that is needed for uses of this+-- function downstream. Those could in principle be re-written.++-- hUnfold :: (Apply p s, HUnfold' p s) => p -> s -> HList (HUnfold p s)+hUnfold p s = hUnfold' p (apply p s)++type HUnfold p s = HUnfoldR p (ApplyR p s)++type family HUnfoldR p res :: [*]+type instance HUnfoldR p HNothing = '[]+type instance HUnfoldR p (HJust (e,s)) = e ': HUnfoldR p (ApplyR p s)++type HUnfold' p res = HUnfoldFD p (ApplyR p res) (HUnfold p res)++class HUnfoldFD p res z | p res -> z where+    hUnfold' :: p -> res -> HList z++instance HUnfoldFD p HNothing '[] where+    hUnfold' _ _ = HNil++instance (Apply p s, HUnfoldFD p (ApplyR p s) z) => HUnfoldFD p (HJust (e,s)) (e ': z) where+    hUnfold' p (HJust (e,s)) = HCons e (hUnfold p s)+++-- ** replicate++{- |++Sometimes the result type can fix the type of the+first argument:++>>> hReplicate Proxy () :: HList '[ (), (), () ]+H[(),(),()]++However, with HReplicate all elements must have the same type, so it may be+easier to use 'HList2List':++>>> list2HList (repeat 3) :: Maybe (HList [Int, Int, Int])+Just H[3,3,3]++-}+class HLengthEq es n => HReplicateFD (n :: HNat) e es+          | n e -> es, es -> n where+    hReplicate :: Proxy n -> e -> HList es++instance HReplicateFD HZero e '[] where+    hReplicate _ _ = HNil++instance (HReplicateFD n e es, e ~ e') => HReplicateFD (HSucc n) e (e' ': es) where+    hReplicate n e = e `HCons` hReplicate (hPred n) e++type HReplicate n e = HReplicateFD n e (HReplicateR n e)++-- | would be associated with 'HReplicate' except we want+-- it to work with `e` of any kind, not just `*` that you can+-- put into a HList. An \"inverse\" of 'HLength'+type family HReplicateR (n :: HNat) (e :: k) :: [k]+type instance HReplicateR HZero e = '[]+type instance HReplicateR (HSucc n) e = e ': HReplicateR n e++{- | HReplicate produces lists that can be converted to ordinary+lists++>>> let two = hSucc (hSucc hZero)+>>> let f = Fun' fromInteger :: Fun' Num Integer++>>> :t applyAB f+applyAB f :: Num b => Integer -> b++>>> hReplicateF two f 3+H[3,3]++>>> hReplicateF Proxy f 3 :: HList [Int, Double, Integer]+H[3,3.0,3]++-}+class HLengthEq r n => HReplicateF (n :: HNat) f z r | r -> n where+    hReplicateF :: HLengthEq r n => Proxy n -> f -> z -> HList r++instance HReplicateF HZero f z '[] where+    hReplicateF _ _ _ = HNil++instance (ApplyAB f z fz,+          HReplicateF n f z r')+  => HReplicateF (HSucc n) f z (fz ': r') where+    hReplicateF n f z = applyAB f z `HCons` hReplicateF (hPred n) f z++-- ** iterate+{- |++This function behaves like 'iterate', with an extra+argument to help figure out the result length++>>> let three = hSucc (hSucc (hSucc hZero))+>>> let f = Fun Just :: Fun '() Maybe++>>> :t applyAB f+applyAB f :: a -> Maybe a++f is applied to different types:++>>> hIterate three f ()+H[(),Just (),Just (Just ())]++It is also possible to specify the length later on,+as done with Prelude.'iterate'++>>> let take3 x | _ <- hLength x `asTypeOf` three = x+>>> take3 $ hIterate Proxy f ()+H[(),Just (),Just (Just ())]++-}+class HLengthEq r n => HIterate n f z r where+    hIterate :: HLengthEq r n => Proxy n -> f -> z -> HList r++instance HIterate HZero f z '[] where+    hIterate _ _ _ = HNil++instance (ApplyAB f z z',+      HIterate n f z' r',+      z ~ z_)+     => HIterate (HSucc n) f z (z_ ': r') where+    hIterate n f z = z `HCons` hIterate (hPred n) f (applyAB f z :: z')++-- * concat++{- |++Like 'concat' but for HLists of HLists.++Works in ghci... puzzling as what is different in doctest (it isn't+@-XExtendedDefaultRules@)++>>> let a = hEnd $ hBuild 1 2 3+>>> let b = hEnd $ hBuild 'a' "abc"+>>> hConcat $ hBuild a b+H[1,2,3,'a',"abc"]++-}+type HConcat xs = HConcatFD xs (HConcatR xs)++hConcat :: HConcat xs => HList xs -> HList (HConcatR xs)+hConcat x = hConcatFD x++type family HConcatR (a :: [*]) :: [*]+type instance HConcatR '[] = '[]+type instance HConcatR (x ': xs) = HAppendListR (UnHList x) (HConcatR xs)++type family UnHList a :: [*]+type instance UnHList (HList a) = a++-- for the benefit of ghc-7.10.1+class HConcatFD xxs xs | xxs -> xs+    where hConcatFD :: HList xxs -> HList xs++instance HConcatFD '[] '[] where+    hConcatFD _ = HNil++instance (HConcatFD as bs, HAppendFD a bs cs) => HConcatFD (HList a ': as) cs where+    hConcatFD (HCons x xs) = x `hAppendFD` hConcatFD xs++class HAppendFD a b ab | a b -> ab where+    hAppendFD :: HList a -> HList b -> HList ab++instance HAppendFD '[] b b where+    hAppendFD _ b = b++instance HAppendFD as bs cs => HAppendFD (a ': as) bs (a ': cs) where+    hAppendFD (HCons a as) bs = a `HCons` hAppendFD as bs+++-- --------------------------------------------------------------------------+-- * traversing HLists++-- ** producing HList+-- *** map+-- $mapNote It could be implemented with 'hFoldr', as we show further below++{- | hMap is written such that the length of the result list+can be determined from the length of the argument list (and+the other way around). Similarly, the type of the elements+of the list is propagated in both directions too.++>>> :set -XNoMonomorphismRestriction+>>> let xs = 1 .*. 'c' .*. HNil+>>> :t hMap (HJust ()) xs+hMap (HJust ()) xs :: Num y => HList '[HJust y, HJust Char]+++These 4 examples show that the constraint on the length (2 in this case)+can be applied before or after the 'hMap'. That inference is independent of the+direction that type information is propagated for the individual elements.+++>>> let asLen2 xs = xs `asTypeOf` (undefined :: HList '[a,b])++>>> let lr xs = asLen2 (applyAB (HMap HRead) xs)+>>> let ls xs = asLen2 (applyAB (HMap HShow) xs)+>>> let rl xs = applyAB (HMap HRead) (asLen2 xs)+>>> let sl xs = applyAB (HMap HShow) (asLen2 xs)+++>>> :t lr+lr+  :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...]++>>> :t rl+rl+  :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...]+++>>> :t ls+ls+  :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String]++>>> :t sl+sl+  :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String]++-}++newtype HMap f = HMap f++hMap f xs = applyAB (HMap f) xs++instance (HMapCxt r f a b, as ~ r a, bs ~ r b)+    => ApplyAB (HMap f) as bs where+    applyAB (HMap f) = hMapAux f+++-- | hMap constrained to HList+hMapL f xs = applyAB (HMapL f) xs++newtype HMapL f = HMapL f++instance (HMapCxt HList f a b, as ~ HList a, bs ~ HList b) => ApplyAB (HMapL f) as bs where+    applyAB (HMapL f) = hMapAux f+++class (SameLength a b, HMapAux r f a b) => HMapCxt r f a b++instance (SameLength a b, HMapAux r f a b) => HMapCxt r f a b++++class HMapAux (r :: [*] -> *) f (x :: [*]) (y :: [*]) where+  hMapAux :: SameLength x y => f -> r x -> r y++instance HMapAux HList f '[] '[] where+  hMapAux       _  _  = HNil++instance (ApplyAB f e e', HMapAux HList f l l', SameLength l l')+    => HMapAux HList f (e ': l) (e' ': l') where+  hMapAux f (HCons x l)    = applyAB f x `HCons` hMapAux f l+++++-- --------------------------------------------------------------------------++-- **** alternative implementation+-- $note currently broken++newtype MapCar f = MapCar f++-- | Same as 'hMap' only a different implementation.+hMapMapCar :: (HFoldr (MapCar f) (HList '[]) l l') =>+    f -> HList l -> l'+hMapMapCar f = hFoldr (MapCar f) HNil++instance ApplyAB f e e' => ApplyAB (MapCar f) (e,HList l) (HList (e' ': l)) where+    applyAB (MapCar f) (e,l) = HCons (applyAB f e) l+++-- --------------------------------------------------------------------------++-- *** @appEndo . mconcat . map Endo@+{- |++>>> let xs = length .*. (+1) .*. (*2) .*. HNil+>>> hComposeList xs "abc"+8+++-}+hComposeList+  :: (HFoldr Comp (a -> a) l (t -> a)) => HList l -> t -> a+hComposeList fs v0 = let r = hFoldr (Comp :: Comp) (\x -> x `asTypeOf` r) fs v0 in r+++-- --------------------------------------------------------------------------++-- *** sequence+{- |+   A heterogeneous version of++   > sequenceA :: (Applicative m) => [m a] -> m [a]++   Only now we operate on heterogeneous lists, where different elements+   may have different types 'a'.+   In the argument list of monadic values (m a_i),+   although a_i may differ, the monad 'm' must be the same for all+   elements. That's why we needed "Data.HList.TypeCastGeneric2" (currently (~)).+   The typechecker will complain+   if we attempt to use hSequence on a HList of monadic values with different+   monads.++   The 'hSequence' problem was posed by Matthias Fischmann+   in his message on the Haskell-Cafe list on Oct 8, 2006++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018708.html>++   <http://www.haskell.org/pipermail/haskell-cafe/2006-October/018784.html>+ -}++class (Applicative m, SameLength a b) => HSequence m a b | a -> b, m b -> a where+    hSequence :: HList a -> m (HList b)+{- ^++[@Maybe@]++>>> hSequence $ Just (1 :: Integer) `HCons` (Just 'c') `HCons` HNil+Just H[1,'c']++>>> hSequence $  return 1 `HCons` Just  'c' `HCons` HNil+Just H[1,'c']+++[@List@]++>>> hSequence $ [1] `HCons` ['c'] `HCons` HNil+[H[1,'c']]+++-}++instance Applicative m => HSequence m '[] '[] where+    hSequence _ = pure HNil++instance (m1 ~ m, Applicative m, HSequence m as bs) =>+    HSequence m (m1 a ': as) (a ': bs) where+    hSequence (HCons a b) = liftA2 HCons a (hSequence b)++-- **** alternative implementation++-- | 'hSequence2' is not recommended over 'hSequence' since it possibly doesn't+-- allow inferring argument types from the result types. Otherwise this version+-- should do exactly the same thing.+--+-- The DataKinds version needs a little help to find the type of the+-- return HNil, unlike the original version, which worked just fine as+--+--  > hSequence l = hFoldr ConsM (return HNil) l++hSequence2 l =+    let rHNil = pure HNil `asTypeOf` (fmap undefined x)+        x = hFoldr (LiftA2 FHCons) rHNil l+    in x++++-- --------------------------------------------------------------------------+++-- --------------------------------------------------------------------------+-- ** producing homogenous lists++-- *** map (no sequencing)+-- $mapOut This one we implement via hFoldr++newtype Mapcar f = Mapcar f++instance (l ~ [e'], ApplyAB f e e', el ~ (e,l)) => ApplyAB (Mapcar f) el l where+    applyAB (Mapcar f) (e, l) = applyAB f e : l++-- A synonym for the complex constraint+type HMapOut f l e = (HFoldr (Mapcar f) [e] l [e])++-- | compare @hMapOut f@ with @'hList2List' . 'hMap' f@+hMapOut :: forall f e l. HMapOut f l e => f -> HList l -> [e]+hMapOut f l = hFoldr (Mapcar f) ([] :: [e]) l+++-- --------------------------------------------------------------------------+-- *** mapM++-- |+--+-- > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b]+--+-- Likewise for 'mapM_'.+--+-- See 'hSequence' if the result list should also be heterogenous.++hMapM   :: (Monad m, HMapOut f l (m e)) => f -> HList l -> [m e]+hMapM f =  hMapOut f++-- | GHC doesn't like its own type.+--+-- > hMapM_ :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m ()+--+-- Without explicit type signature, it's Ok. Sigh.+-- Anyway, Hugs does insist on a better type. So we restrict as follows:+--+hMapM_   :: (Monad m, HMapOut f l (m ())) => f -> HList l -> m ()+hMapM_ f =  sequence_ .  disambiguate . hMapM f+ where+  disambiguate :: [q ()] -> [q ()]+  disambiguate =  id++++++-- --------------------------------------------------------------------------+-- * Ensure a list to contain HNats only+-- | We do so constructively, converting the HList whose elements+-- are Proxy HNat to [HNat]. The latter kind is unpopulated and+-- is present only at the type level.++type family HNats (l :: [*]) :: [HNat]+type instance HNats '[] = '[]+type instance HNats (Proxy n ': l) = n ': HNats l++hNats :: HList l -> Proxy (HNats l)+hNats _ = Proxy+++-- --------------------------------------------------------------------------+-- * Membership tests++-- | Check to see if an HList contains an element with a given type+-- This is a type-level only test++class HMember (e1 :: k) (l :: [k]) (b :: Bool) | e1 l -> b+instance HMember e1 '[] False+instance (HEq e1 e b, HMember' b e1 l br) => HMember  e1 (e ': l) br+class HMember' (b0 :: Bool) (e1 :: k) (l :: [k]) (b :: Bool) | b0 e1 l -> b+instance HMember' True e1 l True+instance (HMember e1 l br) => HMember' False e1 l br++-- | The following is a similar type-only membership test+-- It uses the user-supplied curried type equality predicate pred+type family HMemberP pred e1 (l :: [*]) :: Bool+type instance HMemberP pred e1 '[] = False+type instance HMemberP pred e1 (e ': l) = HMemberP' pred e1 l (ApplyR pred (e1,e))++type family HMemberP' pred e1 (l :: [*]) pb :: Bool+type instance HMemberP' pred e1 l (Proxy True) = True+type instance HMemberP' pred e1 l (Proxy False) = HMemberP pred e1 l+++hMember :: HMember e l b => Proxy e -> Proxy l -> Proxy b+hMember _ _ = Proxy++-- ** Another type-level membership test+--+-- | Check to see if an element e occurs in a list l+-- If not, return 'Nothing+-- If the element does occur, return 'Just l1+-- where l1 is a type-level list without e+class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r+instance HMemberM e1 '[] 'Nothing+instance (HEq e1 e b, HMemberM1 b e1 (e ': l) res)+      =>  HMemberM e1 (e ': l) res++class HMemberM1 (b::Bool) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM1 True e1 (e ': l) ('Just l)+instance (HMemberM e1 l r, HMemberM2 r e1 (e ': l) res)+    => HMemberM1 False e1 (e ': l) res++class HMemberM2 (b::Maybe [k]) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r+instance HMemberM2 Nothing e1 l Nothing+instance HMemberM2 (Just l1) e1 (e ': l) (Just (e ': l1))++-- --------------------------------------------------------------------------++-- * Staged equality for lists+-- $note removed. use Typeable instead+++{-+-- * Static set property based on HEq+class HSet l+instance HSet HNil+instance (HMember e l HFalse, HSet l) => HSet (HCons e l)+-}++-- * Find an element in a set based on HEq+-- | It is a pure type-level operation+class HFind1 e l l n => HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n+instance HFind1 e l l n => HFind e l n++class HFind1 (e :: k) (l :: [k]) (l0 :: [k]) (n :: HNat) | e l -> n++instance (HEq e1 e2 b, HFind2 b e1 l l0 n) => HFind1 e1 (e2 ': l) l0 n+instance Fail (FieldNotFound e1 l0) => HFind1 e1 '[] l0 HZero++class HFind2 (b::Bool) (e :: k) (l::[k]) (l0::[k]) (n:: HNat) | b e l -> n+instance HFind2 True e l l0 HZero+instance HFind1 e l l0 n => HFind2 False e l l0 (HSucc n)++++-- ** Membership test based on type equality++-- | could be an associated type if HEq had one+class HTMember e (l :: [*]) (b :: Bool) | e l -> b+instance HTMember e '[] False+instance (HEq e e' b, HTMember e l b', HOr b b' ~ b'')+      =>  HTMember e (e' ': l) b''++hTMember :: HTMember e l b => e -> HList l -> Proxy b+hTMember _ _ = Proxy+++-- * Intersection based on HTMember++class HTIntersect l1 l2 l3 | l1 l2 -> l3+ where+  -- | Like 'Data.List.intersect'+  hTIntersect :: HList l1 -> HList l2 -> HList l3++instance HTIntersect '[] l '[]+ where+  hTIntersect _ _ = HNil++instance ( HTMember h l1 b+         , HTIntersectBool b h t l1 l2+         )+         => HTIntersect (h ': t) l1 l2+ where+  hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1+   where+    b = hTMember h l1++class HTIntersectBool (b :: Bool) h t l1 l2 | b h t l1 -> l2+ where+ hTIntersectBool :: Proxy b -> h -> HList t -> HList l1 -> HList l2++instance HTIntersect t l1 l2+      => HTIntersectBool True h t l1 (h ': l2)+ where+  hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1)++instance HTIntersect t l1 l2+      => HTIntersectBool False h t l1 l2+ where+  hTIntersectBool _ _ t l1 = hTIntersect t l1+++-- * Convert between heterogeneous lists and homogeneous ones++-- | @hMapOut id@ is similar, except this function is restricted+-- to HLists that actually contain a value (so the list produced+-- will be nonempty). This restriction allows adding a functional+-- dependency, which means that less type annotations can be necessary.+class HList2List l e | l -> e+ where+  hList2List :: HList l -> [e]+  list2HListSuffix :: [e] -> Maybe (HList l, [e])+++list2HList :: HList2List l e => [e] -> Maybe (HList l)+list2HList = fmap fst . list2HListSuffix+++instance HList2List '[e] e+ where+  hList2List (HCons e HNil) = [e]++  list2HListSuffix (e : es) = Just (HCons e HNil, es)+  list2HListSuffix [] = Nothing+++instance HList2List (e' ': l) e+      => HList2List (e ': e' ': l) e+ where+  hList2List (HCons e l) = e:hList2List l++  list2HListSuffix (e : es) = (\(hl,rest) -> (HCons e hl, rest))+                                  <$> list2HListSuffix es+  list2HListSuffix [] = Nothing++-- | @Prism [s] [t] (HList s) (HList t)@+listAsHList x = prism hList2List (\l -> case list2HListSuffix l of+                                 Just (hl,[])  -> Right hl+                                 _ -> Left []) x++-- | @Prism' [a] (HList s)@+--+-- where @s ~ HReplicateR n a@+listAsHList' x = isSimple listAsHList x+++-- --------------------------------------------------------------------------+-- * With 'HMaybe'++-- ** Turn list in a list of justs+-- | the same as @map Just@+--+-- >>> toHJust (2 .*. 'a' .*. HNil)+-- H[HJust 2,HJust 'a']+--+-- >>> toHJust2 (2 .*. 'a' .*. HNil)+-- H[HJust 2,HJust 'a']++class FromHJustR (ToHJustR l) ~ l => ToHJust l+ where+  type ToHJustR l :: [*]+  toHJust :: HList l -> HList (ToHJustR l)++instance ToHJust '[]+ where+  type ToHJustR '[] = '[]+  toHJust HNil = HNil++instance ToHJust l => ToHJust (e ': l)+ where+  type ToHJustR (e ': l) = HJust e ': ToHJustR l+  toHJust (HCons e l) = HCons (HJust e) (toHJust l)++-- | alternative implementation. The Apply instance is in "Data.HList.FakePrelude".+-- A longer type could be inferred.+toHJust2 :: (HMapCxt r (HJust ()) a b,+             ToHJust a, b ~ ToHJustR a -- added to get equivalent inference+             ) => r a -> r b+toHJust2 xs = hMap (HJust ()) xs++-- --------------------------------------------------------------------------+-- ** Extract justs from list of maybes+--+-- >>> let xs = 2 .*. 'a' .*. HNil+-- >>> fromHJust (toHJust xs) == xs+-- True++class (FromHJustR (ToHJustR l) ~ l) => FromHJust l+ where+  type FromHJustR l :: [*]+  fromHJust :: HList l -> HList (FromHJustR l)++instance FromHJust '[]+ where+  type FromHJustR '[] = '[]+  fromHJust HNil = HNil++instance FromHJust l => FromHJust (HNothing ': l)+ where+  type FromHJustR (HNothing ': l) = FromHJustR l+  fromHJust (HCons _ l) = fromHJust l++instance FromHJust l => FromHJust (HJust e ': l)+ where+  type FromHJustR (HJust e ': l) = e ': FromHJustR l+  fromHJust (HCons (HJust e) l) = HCons e (fromHJust l)++-- *** alternative implementation++-- | This implementation is shorter.+fromHJust2 :: (HMapCxt r HFromJust a b) => r a -> r b+fromHJust2 xs = hMap HFromJust xs++data HFromJust = HFromJust+instance (hJustA ~ HJust a) => ApplyAB HFromJust hJustA a where+    applyAB _ (HJust a) = a+++-- --------------------------------------------------------------------------+-- * Annotated lists++data HAddTag t = HAddTag t+data HRmTag    = HRmTag++-- hAddTag :: HMapCxt (HAddTag t) l r => t -> HList l -> HList r+hAddTag t l = hMap (HAddTag t) l++-- hRmTag ::  HMapCxt HRmTag l => HList l -> HList (HMapR HRmTag l)+hRmTag l    = hMap HRmTag l++instance (et ~ (e,t)) => ApplyAB (HAddTag t) e et+ where+  applyAB (HAddTag t) e = (e,t)+++instance (e' ~ e) => ApplyAB HRmTag (e,t) e'+ where+  applyAB _ (e,_) = e+++-- | Annotate list with a type-level Boolean+--+-- > hFlag :: HMapCxt (HAddTag (Proxy True)) l r => HList l -> HList r+hFlag l = hAddTag hTrue l+++-- --------------------------------------------------------------------------+-- * Splitting by HTrue and HFalse++-- | Analogus to Data.List.'Data.List.partition' 'snd'. See also 'HPartition'+--+-- >>> let (.=.) :: p x -> y -> Tagged x y; _ .=. y = Tagged y+-- >>> hSplit $ hTrue .=. 2 .*. hTrue .=. 3 .*. hFalse .=. 1 .*. HNil+-- (H[2,3],H[1])+--+-- it might make more sense to instead have @LVPair Bool e@+-- instead of @(e, Proxy Bool)@ since the former has the same+-- runtime representation as @e@++class HSplit l+ where+  type HSplitT l :: [*]+  type HSplitF l :: [*]+  hSplit :: HList l -> (HList (HSplitT l), HList (HSplitF l))++instance HSplit '[]+ where+  type HSplitT '[] = '[]+  type HSplitF '[] = '[]+  hSplit HNil = (HNil,HNil)++instance HSplit l => HSplit ((e, Proxy True) ': l)+ where++  type HSplitT ((e,Proxy True) ': l) = e ': HSplitT l+  type HSplitF ((e,Proxy True) ': l) = HSplitF l++  hSplit (HCons (e,_) l) = (HCons e l',l'')+   where+    (l',l'') = hSplit l++instance HSplit l => HSplit ((e,Proxy False) ': l)+ where+  type HSplitT ((e,Proxy False) ': l) = HSplitT l+  type HSplitF ((e,Proxy False) ': l) = e ': HSplitF l++  hSplit (HCons (e,_) l) = (l',HCons e l'')+   where+    (l',l'') = hSplit l+++instance HSplit l => HSplit (Tagged True e ': l)+ where++  type HSplitT (Tagged True e ': l) = e ': HSplitT l+  type HSplitF (Tagged True e ': l) = HSplitF l++  hSplit (HCons (Tagged e) l) = (HCons e l',l'')+   where+    (l',l'') = hSplit l++instance HSplit l => HSplit (Tagged False e ': l)+ where+  type HSplitT (Tagged False e ': l) = HSplitT l+  type HSplitF (Tagged False e ': l) = e ': HSplitF l++  hSplit (HCons (Tagged e) l) = (l',HCons e l'')+   where+    (l',l'') = hSplit l+{-++Let expansion makes a difference to Hugs:++HListPrelude> let x = (hFlag (HCons "1" HNil)) in hSplit x+(HCons "1" HNil,HNil)+HListPrelude> hSplit (hFlag (HCons "1" HNil))+ERROR - Unresolved overloading+*** Type       : HSplit (HCons ([Char],HTrue) HNil) a b => (a,b)+*** Expression : hSplit (hFlag (HCons "1" HNil))+++-}++-- --------------------------------------------------------------------------+-- * Splitting by Length++{- | 'splitAt'++setup++>>> let two = hSucc (hSucc hZero)+>>> let xsys = hEnd $ hBuild 1 2 3 4++If a length is explicitly provided, the resulting lists are inferred++>>> hSplitAt two xsys+(H[1,2],H[3,4])++>>> let sameLength_ :: SameLength a b => r a -> r b -> r a; sameLength_ = const+>>> let len2 x = x `sameLength_` HCons () (HCons () HNil)++If the first chunk of the list (a) has to be a certain length, the type of the+Proxy argument can be inferred.++>>> case hSplitAt Proxy xsys of (a,b) -> (len2 a, b)+(H[1,2],H[3,4])++-}+class (HLengthEq xs n,+       HAppendList1 xs ys xsys+       )+      => HSplitAt (n :: HNat) xsys xs ys+                   | n xsys -> xs ys+                      , xs ys -> xsys+                      , xs -> n+                     where+    hSplitAt :: Proxy n -> HList xsys -> (HList xs, HList ys)++instance (HSplitAt1 '[] n xsys xs ys,+          HAppendList1 xs ys xsys,+          HLengthEq xs n) =>+    HSplitAt n xsys xs ys where+      hSplitAt n xsys = hSplitAt1 HNil n xsys++-- | helper for 'HSplitAt'+class HSplitAt1 accum (n :: HNat) xsys xs ys | accum n xsys -> xs ys where+    hSplitAt1 :: HList accum -> Proxy n -> HList xsys -> (HList xs, HList ys)++instance HRevApp accum '[] xs => HSplitAt1 accum HZero ys xs ys where+    hSplitAt1 xs _zero ys = (hReverse_ xs, ys)++instance HSplitAt1 (b ': accum) n bs xs ys+    => HSplitAt1 accum (HSucc n) (b ': bs) xs ys where+    hSplitAt1 accum n (HCons b bs) = hSplitAt1 (HCons b accum) (hPred n) bs++{- | a better way to write @HLength xs ~ n@ because:++1. it works properly with ghc-7.10 (probably another example of ghc bug #10009)++2. it works backwards a bit in that if @n@ is known, then @xs@ can be+   refined:++>>> undefined :: HLengthEq xs HZero => HList xs+H[]++-}+class (SameLength' (HReplicateR n ()) xs,+        HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq (xs :: [*]) (n :: HNat) | xs -> n++instance (SameLength' (HReplicateR n ()) xs,+          HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq xs n++class HLengthEq1 (xs :: [*]) n -- pick the instance based on n's constructor+instance (HLengthEq xs n, xxs ~ (x ': xs)) => HLengthEq1 xxs (HSucc n)+instance (xxs ~ '[]) => HLengthEq1 xxs HZero++class HLengthEq2 (xs :: [*]) n | xs -> n -- pick the instance based on xs' constructor+instance (HLengthEq xs n, sn ~ HSucc n) => HLengthEq2 (x ': xs) sn+instance zero ~ HZero => HLengthEq2 '[] zero++-- | @HLengthGe xs n@ says that @HLength xs >= n@.+--+-- unlike the expression with a type family HLength,+-- ghc assumes @xs ~ (aFresh ': bFresh)@ when given a+-- constraint @HLengthGe xs (HSucc HZero)@+class HLengthGe (xs :: [*]) (n :: HNat)+instance (HLengthGe xs n, xxs ~ (x ': xs)) => HLengthGe xxs (HSucc n)+instance HLengthGe xxs HZero++-- | @HAppendList1 xs ys xsys@ is the type-level way of saying @xs ++ ys == xsys@+--+-- used by 'HSplitAt'+class HStripPrefix xs xsys ys+      => HAppendList1 (xs :: [k]) (ys :: [k]) (xsys :: [k])+        | xs ys -> xsys,+          xs xsys -> ys+          -- , ys xsys -> xs+          -- hard to prove++instance HAppendList1 '[] ys ys+instance (HAppendList1 xs ys zs) => HAppendList1 (x ': xs) ys (x ': zs)+++-- | analog of 'Data.List.stripPrefix'+class HStripPrefix xs xsys ys | xs xsys -> ys+instance (x' ~ x, HStripPrefix xs xsys ys) => HStripPrefix (x' ': xs) (x ': xsys) ys+instance HStripPrefix '[] ys ys+++-- ** take++class HTake (n :: HNat) xs ys | n xs -> ys where+    hTake :: (HLengthEq ys n, HLengthGe xs n) => Proxy n -> HList xs -> HList ys++instance HTake HZero xs '[] where+    hTake _ _ = HNil++instance (HLengthEq ys n, HLengthGe xs n, HTake n xs ys)+        => HTake (HSucc n) (x ': xs) (x ': ys) where+    hTake sn (HCons x xs) = HCons x (hTake (hPred sn) xs)++-- ** drop++class HDrop (n :: HNat) xs ys | n xs -> ys where+    hDrop :: HLengthGe xs n => Proxy n -> HList xs -> HList ys++instance HDrop HZero xs xs where+    hDrop _ xs = xs++instance (HLengthGe xs n, HDrop n xs ys) => HDrop (HSucc n) (x ': xs) ys where+    hDrop sn (HCons _ xs) = hDrop (hPred sn) xs+++-- * Conversion to and from tuples++class HTuple v t | v -> t, t -> v where+    -- | alternatively: @hUncurry (,,,)@+    hToTuple :: HList v -> t+    hFromTuple :: t -> HList v++-- | @Iso (HList v) (HList v') a b@+hTuple x = iso hToTuple hFromTuple x++-- | @Iso' (HList v) a@+hTuple' x = isSimple hTuple x++instance HTuple '[] () where+    hToTuple HNil = ()+    hFromTuple () = HNil++instance HTuple '[a,b] (a,b) where+    hToTuple (a `HCons` b `HCons` HNil) = (a,b)+    hFromTuple (a,b) = (a `HCons` b `HCons` HNil)++instance HTuple '[a,b,c] (a,b,c) where+    hToTuple (a `HCons` b `HCons` c `HCons` HNil) = (a,b,c)+    hFromTuple (a,b,c) = (a `HCons` b `HCons` c `HCons` HNil)++instance HTuple '[a,b,c,d] (a,b,c,d) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a,b,c,d)+    hFromTuple (a,b,c,d) = (a `HCons` b `HCons` c `HCons` d `HCons` HNil)++instance HTuple '[a,b,c,d,e] (a,b,c,d,e) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil) = (a,b,c,d,e)+    hFromTuple (a,b,c,d,e) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil)++instance HTuple '[a,b,c,d,e,f] (a,b,c,d,e,f) where+    hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a,b,c,d,e,f)+    hFromTuple (a,b,c,d,e,f) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil)+++-- | 'tails'+class HTails a b | a -> b, b -> a where+    hTails :: HList a -> HList b++instance HTails '[] '[HList '[]] where+    hTails _ = HCons HNil HNil++instance (HTails xs ys) => HTails (x ': xs) (HList (x ': xs) ': ys) where+    hTails xxs@(HCons _x xs) = xxs `HCons` hTails xs+++-- | 'inits'+class HInits a b | a -> b, b -> a where+    hInits :: HList a -> HList b++instance HInits1 a b => HInits a (HList '[] ': b) where+    hInits xs = HNil `HCons` hInits1 xs+++-- | behaves like @tail . inits@+class HInits1 a b | a -> b, b -> a where+    hInits1 :: HList a -> HList b++instance HInits1 '[] '[HList '[]] where+    hInits1 _ = HCons HNil HNil++instance (HInits1 xs ys,+          HMapCxt HList (FHCons2 x) ys ys',+          HMapCons x ys ~ ys',+          HMapTail ys' ~ ys)+  => HInits1 (x ': xs) (HList '[x] ':  ys') where+    hInits1 (HCons x xs) = HCons x HNil `HCons` hMap (FHCons2 x) (hInits1 xs)+++-- | similar to 'FHCons'+data FHCons2 x = FHCons2 x++instance (hxs ~ HList xs,+          hxxs ~ HList (x ': xs))+  => ApplyAB (FHCons2 x) hxs hxxs where+  applyAB (FHCons2 x) xs = HCons x xs+++-- | evidence to satisfy the fundeps in HInits+type family HMapCons (x :: *) (xxs :: [*]) :: [*]+type instance HMapCons x (HList a ': b) = HList (x ': a) ': HMapCons x b+type instance HMapCons x '[] = '[]++-- | evidence to satisfy the fundeps in HInits+type family HMapTail (xxs :: [*]) :: [*]+type instance HMapTail ( HList (a ': as) ': bs) = HList as ': HMapTail bs+type instance HMapTail '[] = '[]+++-- * partition++{- | @HPartitionEq f x1 xs xi xo@ is analogous to++> (xi,xo) = partition (f x1) xs++where @f@ is a \"function\" passed in using it's instance of 'HEqBy'+-}+class HPartitionEq f x1 xs xi xo | f x1 xs -> xi xo where+    hPartitionEq :: Proxy f -> Proxy x1 -> HList xs -> (HList xi, HList xo)++instance HPartitionEq f x1 '[] '[] '[] where+    hPartitionEq _ _ _ = (HNil, HNil)++instance+   (HEqBy f x1 x b,+    HPartitionEq1 b f x1 x xs xi xo) => HPartitionEq f x1 (x ': xs) xi xo where+      hPartitionEq f x1 (HCons x xs) = hPartitionEq1 (Proxy :: Proxy b) f x1 x xs++class HPartitionEq1 (b :: Bool) f x1 x xs xi xo | b f x1 x xs -> xi xo where+    hPartitionEq1 :: Proxy b -> Proxy f -> Proxy x1 -> x -> HList xs -> (HList xi, HList xo)++instance HPartitionEq f x1 xs xi xo =>+    HPartitionEq1 True f x1 x xs (x ': xi) xo where+      hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of+         (xi, xo) -> (x `HCons` xi, xo)++instance HPartitionEq f x1 xs xi xo =>+    HPartitionEq1 False f x1 x xs xi (x ': xo) where+      hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of+         (xi, xo) -> (xi, x `HCons` xo)+++-- * groupBy++{- | @HGroupBy f x y@ is analogous to @y = 'groupBy' f x@++given that @f@ is used by 'HEqBy'+-}+class HGroupBy (f :: t) (as :: [*]) (gs :: [*]) | f as -> gs, gs -> as where+    hGroupBy :: Proxy f -> HList as -> HList gs++instance (HSpanEqBy f a as fst snd,+          HGroupBy f snd gs) => HGroupBy f (a ': as) (HList (a ': fst) ': gs) where+    hGroupBy f (HCons x xs) = case hSpanEqBy f x xs of+                      (first, second) -> (x `HCons` first) `HCons` hGroupBy f second++instance HGroupBy f '[] '[] where+    hGroupBy _f HNil = HNil++-- * span++-- | @HSpanEq x y fst snd@ is analogous to @(fst,snd) = 'span' (== x) y@+class HSpanEqBy (f :: t) (x :: *) (y :: [*]) (fst :: [*]) (snd :: [*])+      | f x y -> fst snd, fst snd -> y where+  hSpanEqBy :: Proxy f -> x -> HList y -> (HList fst, HList snd)++instance (HSpanEqBy1 f x y fst snd,+          HAppendListR fst snd ~ y)+    => HSpanEqBy f x y fst snd where+  hSpanEqBy f x y =  hSpanEqBy1 f x y++class HSpanEqBy1 (f :: t) (x :: *) (y :: [*]) (i :: [*]) (o :: [*])+      | f x y -> i o where+  hSpanEqBy1 :: Proxy f -> x -> HList y -> (HList i, HList o)++class HSpanEqBy2 (b :: Bool) (f :: t) (x :: *) (y :: *) (ys :: [*]) (i :: [*]) (o :: [*])+      | b f x y ys -> i o where+  hSpanEqBy2 :: Proxy b -> Proxy f -> x -> y -> HList ys -> (HList i, HList o)+++instance (HEqBy f x y b,+          HSpanEqBy2 b f x y ys i o) => HSpanEqBy1 f x (y ': ys) i o where+  hSpanEqBy1 f x (HCons y ys) = hSpanEqBy2 (Proxy :: Proxy b) f x (y :: y) (ys :: HList ys)++instance HSpanEqBy1 f x '[] '[] '[] where+    hSpanEqBy1 _f _x _xs = (HNil, HNil)++instance HSpanEqBy1 f x zs i o+    => HSpanEqBy2 True f x y zs (y ': i) o where+  hSpanEqBy2 _ f x y zs = case hSpanEqBy1 f x zs of+                                      (i, o) -> (HCons y i, o)++instance HSpanEqBy2 False f x y ys '[] (y ': ys) where+  hSpanEqBy2 _b _f _x y ys = (HNil, HCons y ys)++++-- * zip++-- $note see alternative implementations in "Data.HList.HZip"++++instance (SameLengths [x,y,xy], HZipList x y xy) => HUnzip HList x y xy where+  hUnzip = hUnzipList++instance (SameLengths [x,y,xy], HZipList x y xy) => HZip HList x y xy where+  hZip = hZipList+++class HZipList x y l | x y -> l, l -> x y where+  hZipList   :: HList x -> HList y -> HList l+  hUnzipList :: HList l -> (HList x, HList y)++instance HZipList '[] '[] '[] where+  hZipList _ _ = HNil+  hUnzipList _ = (HNil, HNil)++instance ((x,y)~z, HZipList xs ys zs) => HZipList (x ': xs) (y ': ys) (z ': zs) where+  hZipList (HCons x xs) (HCons y ys) = (x,y) `HCons` hZipList xs ys+  hUnzipList (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzipList zs in (x `HCons` xs, y `HCons` ys)++-- * Monoid instance++{- | Analogous to the Monoid instance for tuples++>>> import Data.Monoid+>>> mempty :: HList '[(), All, [Int]]+H[(),All {getAll = True},[]]++>>> mappend (hBuild "a") (hBuild "b") :: HList '[String]+H["ab"]++-}+instance+   (HProxies a,+    HMapCxt HList ConstMempty (AddProxy a) a,+    HZip HList a a aa,+    HMapCxt HList UncurryMappend aa a) => Monoid (HList a) where+  mempty = hMap ConstMempty+            $ (hProxies :: HList (AddProxy a))+#if __GLASGOW_HASKELL__ <= 906+  mappend a b = hMap UncurryMappend $ hZip a b+#endif++instance+    (HZip HList a a aa,+     HMapCxt HList UncurryMappend aa a) => Semigroup (HList a) where+  a <> b = hMap UncurryMappend $ hZip a b++-- ** helper functions++data ConstMempty = ConstMempty+instance (x ~ Proxy y, Monoid y) => ApplyAB ConstMempty x y where+    applyAB _ _ = mempty++data UncurryMappend = UncurryMappend+instance (aa ~ (a,a), Monoid a) => ApplyAB UncurryMappend aa a where+    applyAB _ = uncurry mappend++data UncurrySappend = UncurrySappend+instance (aa ~ (a,a), Semigroup a) => ApplyAB UncurrySappend aa a where+    applyAB _ = uncurry (<>)
+ hlist/Data/HList/HListPrelude.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE CPP #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   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+++class HExtend e l where+  type HExtendR e l+  (.*.) :: e -> l -> HExtendR e l++infixr 2 .*.+++-- | to keep types shorter, '.*.' used with Proxy avoids+-- producing a @Proxy :: Proxy '[Label x,Label y,Label z]@+-- if @Proxy :: Proxy '[x,y,z]@ is not a kind error (as it+-- is when mixing Label6 and Label3 labels).+--+-- ghc-7.6 does not accept @Proxy ('[] :: [k])@ so for now+-- require @k ~ *@+instance HExtend (Label x) (Proxy ('[] :: [*])) where+    type HExtendR (Label x) (Proxy ('[] :: [*])) = Proxy '[x]+    (.*.) _ _ = Proxy+++-- | similar to 'emptyRecord', 'emptyTIP', emptyHList (actually called 'HNil'),+-- except emptyProxy is the rightmost argument to '.*.'+emptyProxy = Proxy :: Proxy ('[] :: [*])++-- Poly-kinded+class SubType l l'++-- subType :: SubType l l' => l -> l' -> ()+-- subType _ _ = ()++class HAppend l1 l2 where+  hAppend :: l1 -> l2 -> HAppendR l1 l2++-- | poly-kinded, but 'hAppend' only works in cases where the kind variable+-- `k` is `*`+type family HAppendR (l1::k) (l2::k) :: k+-- class HMember e1 l (b :: Bool) | e1 l -> b++-- 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 :: k) (l :: [k])++class HProject l l' where+  hProject :: l -> l'++-- | Map a type (key) to a natural (index) within the collection+-- This is a purely type-level computation+class HType2HNat (e :: k) (l :: [k]) (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'+++class HDeleteAtLabel (r :: [*] -> *) (l :: k) v v' | l v -> v' where+    hDeleteAtLabel :: Label l -> r v -> r v'+++++-- | 'unzip'+class SameLengths [x,y,xy] => HUnzip (r :: [*] -> *) x y xy+        | x y -> xy, xy -> x y where+  hUnzip :: r xy -> (r x, r y)++-- | 'zip'. Variant supports hUnzip, but not hZip ('hZipVariant' returns a Maybe)+class HUnzip r x y xy => HZip (r :: [*] -> *) x y xy where+  hZip :: r x -> r y -> r xy++#if __GLASGOW_HASKELL__ != 706+instance (lv ~ Tagged l v, HUnzip Proxy ls vs lvs)+    => HUnzip Proxy (Label l ': ls) (v ': vs) (lv ': lvs) where+    hUnzip _ = (Proxy, Proxy)++instance HUnzip Proxy '[] '[] '[] where hUnzip _ = (Proxy, Proxy)+++{- | Missing from GHC-7.6.3 due to a bug:++> let r = hEnd $ hBuild 1 2 3+> *Data.HList> hZipList r r+> H[(1,1),(2,2),(3,3)]+> *Data.HList> hZip r r+>+> <interactive>:30:1:+>     Couldn't match type `Label k l' with `Integer'+>     When using functional dependencies to combine+>       HUnzip+>         (Proxy [*]) ((':) * (Label k l) ls) ((':) * v vs) ((':) * lv lvs),+>         arising from the dependency `xy -> x y'+>         in the instance declaration at Data/HList/HListPrelude.hs:96:10+>       HUnzip+>         HList+>         ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+>         ((':) * Integer ((':) * Integer ((':) * Integer ('[] *))))+>         ((':)+>            *+>            (Integer, Integer)+>            ((':) * (Integer, Integer) ((':) * (Integer, Integer) ('[] *)))),+>         arising from a use of `hZip' at <interactive>:30:1-4+>     In the expression: hZip r r+>     In an equation for `it': it = hZip r r++-}+instance HUnzip Proxy ls vs lvs+      => HZip Proxy ls vs lvs where+  hZip _ _ = Proxy+#endif++
+ hlist/Data/HList/HOccurs.hs view
@@ -0,0 +1,175 @@++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Result-type-driven operations on typeful heterogeneous lists.+-}++module Data.HList.HOccurs (+    module Data.HList.HOccurs,+    ) where++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.++class HOccurrence (e1 :: *) (l :: [*]) (l' :: [*]) | e1 l -> l' where+    hOccurrence :: Proxy e1 -> HList l -> HList l'++instance HOccurrence e1 '[] '[] where+    hOccurrence _ = id++instance (HEq e1 e b, HOccurrence' b e1 (e ': l) l')+    => HOccurrence e1 (e ': l) l' where+    hOccurrence = hOccurrence' (Proxy::Proxy b)++class HOccurrence' (b :: Bool) (e1 :: *) (l :: [*]) (l' :: [*]) | b e1 l -> l' where+    hOccurrence' :: Proxy b -> Proxy e1 -> HList l -> HList l'++instance HOccurrence' True e1 (e ': l) (e ': l) where+    hOccurrence' _ _ = id++instance HOccurrence e1 l l' => HOccurrence' False e1 (e ': l) l' where+    hOccurrence' _ e (HCons _ l) = hOccurrence e l+++-- --------------------------------------------------------------------------+-- Zero or more occurrences++class HOccursMany e (l :: [*]) where+  hOccursMany :: HList l -> [e]++instance (HOccurrence e l l', HOccursMany' e l')+    => HOccursMany e l+ where+  hOccursMany l = hOccursMany' (hOccurrence (Proxy::Proxy e) 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+++-- --------------------------------------------------------------------------+-- One or more occurrences++hOccursMany1 :: forall e l l'.+                (HOccurrence e l (e ': l'), HOccursMany e l') =>+                HList l -> (e,[e])+hOccursMany1 l = case hOccurrence (Proxy :: Proxy e) l of+                   (HCons e l') -> (e,hOccursMany (l'::HList l'))++-- --------------------------------------------------------------------------+-- The first occurrence++hOccursFst :: forall e l l'. HOccurrence e l (e ': l') => HList l -> e+hOccursFst l = case hOccurrence (Proxy::Proxy e) l of HCons e _ -> e++-- --------------------------------------------------------------------------+-- One occurrence and nothing is left+-- This constraint is used in many places++data TypeNotFound e++instance (HOccurrence e (x ': y) l', HOccurs' e l' (x ': y))+    => HOccurs e (HList (x ': y)) where+    hOccurs = hOccurs' (Proxy :: Proxy (x ': y)) . hOccurrence (Proxy ::Proxy e)++-- | l0 is the original list so that when we reach the end of l+-- without finding an e, we can report an error that gives an+-- idea about what the original list was.+class HOccurs' e l (l0 :: [*]) where+    hOccurs' :: Proxy l0 -> HList l -> e++instance Fail (FieldNotFound e (HList l0)) => HOccurs' e '[] l0 where+    hOccurs' = error "HOccurs'' Fail failed"++instance HOccursNot e l => HOccurs' e (e ': l) l0 where+    hOccurs' _ (HCons e _) = e++-- | lookup a value in the collection (TIP usually) and return the TIP with that+-- element deleted. Used to implement 'tipyTuple'.+hOccursRest tip = case hOccurs tip of+  x -> (x, hDeleteAtLabel (asLabel x) tip)+  where asLabel :: x -> Label x+        asLabel _ = Label+++-- --------------------------------------------------------------------------+-- Zero or at least one occurrence++hOccursOpt :: forall e l l'.+              (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e+hOccursOpt = hOccursOpt' . hOccurrence (Proxy :: Proxy e)++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++instance HOccursNot1 e xs xs => HOccursNot e xs++class HOccursNot1 (e :: k) (xs :: [k]) (xs0 :: [k])++instance HOccursNot1 (e :: k) ('[]::[k]) l0+instance (HEq e e1 b, HOccursNot2 b e l l0) => HOccursNot1 e (e1 ': l) l0+class HOccursNot2 (b :: Bool) e (l :: [k]) (l0 :: [k])+instance Fail (ExcessFieldFound e l0) => HOccursNot2 True e l l0+instance HOccursNot1 e l l0 => HOccursNot2 False e l l0+++-- --------------------------------------------------------------------------++instance HProject (HList l) (HList '[]) where+  hProject _ = HNil++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++Retrieve the Breed of an animal.++> ghci-or-hugs> hOccurs myAnimal :: Breed+> Cow+++Normal hOccurs requires specification of the result type even if the result+type is determined by the fact that we are faced with a singleton list.++> ghci-or-hugs> hOccurs (HCons 1 HNil)+>+> <interactive>:1:+>     No instance for (HOccurs e1 (HCons e HNil))+++However, hOccurs can be elaborated as improved as follows:++> ghci-or-hugs> hLookup (HCons 1 HNil)+> 1++-}
+ hlist/Data/HList/HSort.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE CPP #-}+{- | Description: sorting++Benchmarks for these functions can be found at+<http://code.haskell.org/~aavogt/HList-nodup/Run.html>.++See <Data-HList-CommonMain.html#v:hSort>+for the public interface.++-}+module Data.HList.HSort where++import Data.HList.HList+import Data.HList.FakePrelude+import Data.HList.Label3++#if __GLASGOW_HASKELL__ > 707+import GHC.TypeLits (type (<=?), CmpSymbol)+-- | only in ghc >= 7.7+instance ((x <=? y) ~ b) => HEqBy HLeFn x y b+-- | only in ghc >= 7.7++{- |++>>> let b1 = Proxy :: HEqBy HLeFn "x" "y" b => Proxy b+>>> :t b1+b1 :: Proxy 'True++>>> let b2 = Proxy :: HEqBy HLeFn "x" "x" b => Proxy b+>>> :t b2+b2 :: Proxy 'True++>>> let b3 = Proxy :: HEqBy HLeFn "y" "x" b => Proxy b+>>> :t b3+b3 :: Proxy 'False++-}+instance (HEq (CmpSymbol x y) GT nb, HNot nb ~ b) => HEqBy HLeFn x y b+#endif++-- | the \"standard\" '<=' for types. Reuses 'HEqBy'+--+-- Note that ghc-7.6 is missing instances for Symbol and Nat, so that+-- sorting only works 'HNat' (as used by "Data.HList.Label3").+data HLeFn++instance HEqByFn HLeFn++instance (HLe x y ~ b) => HEqBy HLeFn x y b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Tagged x v) (Tagged y w) b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Label x) (Label y) b+instance HEqBy HLeFn x y b => HEqBy HLeFn (Proxy x) (Proxy y) b++-- | Data.HList.Label3 labels can only be compared if they belong+-- to the same namespace.+instance (HEqBy HLeFn n m b, ns ~ ns')+     => HEqBy HLeFn (Lbl n ns desc) (Lbl m ns' desc') b+++-- | analogous to 'Data.Ord.Down'+data HDown a+instance HEqByFn a => HEqByFn (HDown a)+instance HEqBy f y x b => HEqBy (HDown f) x y b++-- | The HEqBy instances for @HNeq HLeFn@ gives '<'+data HNeq le+instance HEqByFn a => HEqByFn (HNeq a)+instance (HEqBy le y x b1, HNot b1 ~ b2) => HEqBy (HNeq le) x y b2++{- | @HIsAscList le xs b@ is analogous to++> b = all (\(x,y) -> x `le` y) (xs `zip` tail xs)++-}+class HEqByFn le => HIsAscList le (xs :: [*]) (b :: Bool) | le xs -> b++instance HEqByFn le => HIsAscList le '[x] True+instance HEqByFn le => HIsAscList le '[] True+instance (HEqBy le x y b1,+#if __GLASGOW_HASKELL__ > 906+         HEqByFn le,+#endif+         HIsAscList le (y ': ys) b2,+         HAnd b1 b2 ~ b3)  => HIsAscList le (x ': y ': ys) b3+++-- | quick sort with a special case for sorted lists+class (SameLength a b, HEqByFn le) => HSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hSortBy :: Proxy le -> HList a -> HList b++type HSort x y = HSortBy HLeFn x y++hSort :: HSort x y => HList x -> HList y+hSort xs = hSortBy (Proxy :: Proxy HLeFn) xs++instance (SameLength a b,+          HIsAscList le a ok,+          HSortBy1 ok le a b,+          HEqByFn le) => HSortBy le a b where+    hSortBy = hSortBy1 (Proxy :: Proxy ok)++instance HSortBy1 True le a a where+    hSortBy1 _ _ a = a -- already sorted++instance HQSortBy le a b => HSortBy1 False le a b where+    hSortBy1 _ = hQSortBy++class HSortBy1 ok le (a :: [*]) (b :: [*]) | ok le a -> b where+    hSortBy1 :: Proxy ok -> Proxy le -> HList a -> HList b++-- * Merge Sort++{- | HMSortBy is roughly a transcription of this merge sort++> msort [] = []+> msort [x] = [x]+> msort [x,y] = hSort2 x y+> msort xs = case splitAt (length xs `div` 2) xs of+>              (a,b) -> msort a `merge` msort b++> hSort2 x y+>     | x <= y    = [x,y]+>     | otherwise = [y,x]++> merge (x : xs) (y : ys)+>   | x > y     = y : merge (x : xs) ys+>   | otherwise = x : merge xs (y : ys)++-}+class HEqByFn le => HMSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hMSortBy :: Proxy le -> HList a -> HList b+++instance HEqByFn le => HMSortBy le '[] '[] where hMSortBy _ x = x+instance HEqByFn le => HMSortBy le '[x] '[x] where hMSortBy _ x = x+instance (HSort2 b x y ab, HEqBy le x y b, HEqByFn le) =>+    HMSortBy le '[x,y] ab where+      hMSortBy _ (a `HCons` b `HCons` HNil) = hSort2 (Proxy :: Proxy b) a b++class HSort2 b x y ab | b x y -> ab where+    hSort2 :: Proxy b -> x -> y -> HList ab++instance HSort2 True x y '[x,y] where+    hSort2 _ x y = x `HCons` y `HCons` HNil++instance HSort2 False x y '[y,x] where+    hSort2 _ x y = y `HCons` x `HCons` HNil++instance (HMerge le xs' ys' sorted,+#if __GLASGOW_HASKELL__ > 906+          HEqByFn le,+#endif+          HMSortBy le ys ys',+          HMSortBy le xs xs',+          HLengthEq (a ': b ': c ': cs) n2,+          HDiv2 n2 ~ n,+          HSplitAt n (a ': b ': c ': cs) xs ys)+  => HMSortBy le (a ': b ': c ': cs) sorted where+  hMSortBy le abbs = case hSplitAt (Proxy :: Proxy n) abbs of+      (xs, ys) -> hMerge le (hMSortBy le xs) (hMSortBy le ys)+++class HMerge le x y xy | le x y -> xy where+    hMerge :: Proxy le -> HList x -> HList y -> HList xy++instance HMerge le '[] '[] '[] where hMerge _ _ _ = HNil+instance HMerge le (x ': xs) '[] (x ': xs) where hMerge _ x _ = x+instance HMerge le '[] (x ': xs) (x ': xs) where hMerge _ _ x = x++instance (HEqBy le x y b,+          HMerge1 b (x ': xs) (y ': ys) (l ': ls) hhs,+          HMerge le ls hhs srt)+    => HMerge le (x ': xs) (y ': ys) (l ': srt) where+  hMerge le xxs yys = case hMerge1 (Proxy :: Proxy b) xxs yys of+        (HCons l ls, hhs) -> l `HCons` hMerge le ls hhs++type HMerge1 b x y min max = (HCond b (HList x) (HList y) (HList min),+                              HCond b (HList y) (HList x) (HList max))+hMerge1 b x y = (hCond b x y, hCond b y x)++-- * Quick sort+{- | HQSortBy is this algorithm++> qsort (x : xs @ (_ : _)) = case partition (<= x) xs of+>                  (le, gt) -> qsort le ++ x : qsort gt+> qsort xs = xs++on random inputs that are not pathological (ie. not already sorted or reverse+sorted) this turns out to be faster than HMSortBy, so it is used by default.++-}+class HQSortBy le (a :: [*]) (b :: [*]) | le a -> b where+    hQSortBy :: Proxy le -> HList a -> HList b++instance HQSortBy le '[] '[] where hQSortBy _ x = x+instance HQSortBy le '[x] '[x] where hQSortBy _ x = x+instance (HPartitionEq le a (b ': bs) bGeq bLt,+        HQSortBy le bLt  sortedLt,+        HQSortBy le bGeq sortedGeq,+        HAppendListR sortedLt (a ': sortedGeq) ~ sorted,+        HAppendList sortedLt (a ': sortedGeq)) =>+    HQSortBy le (a ': b ': bs) sorted where+    hQSortBy le (a `HCons` xs) = case hPartitionEq le (Proxy :: Proxy a) xs of+                      (g,l) -> hQSortBy le l `hAppendList` (a `HCons` hQSortBy le g)+++++-- * More efficient HRLabelSet / HLabelSet+{- | Provided the labels involved have an appropriate instance of HEqByFn,+it would be possible to use the following definitions:++> type HRLabelSet = HSet+> type HLabelSet  = HSet++-}+class HEqByFn lt => HSetBy lt (ps :: [*])+instance (HEqByFn lt, HSortBy lt ps ps', HAscList lt ps') => HSetBy lt ps++class HSetBy (HNeq HLeFn) ps => HSet (ps :: [*])+instance HSetBy (HNeq HLeFn) ps => HSet ps++{- |++>>> let xx = Proxy :: HIsSet [Label "x", Label "x"] b => Proxy b+>>> :t xx+xx :: Proxy 'False++>>> let xy = Proxy :: HIsSet [Label "x", Label "y"] b => Proxy b+>>> :t xy+xy :: Proxy 'True++-}+class HIsSet (ps :: [*]) (b :: Bool) | ps -> b+instance HIsSetBy (HNeq HLeFn) ps b => HIsSet ps b++class HEqByFn lt => HIsSetBy lt (ps :: [*]) (b :: Bool) | lt ps -> b+instance (HEqByFn lt, HSortBy lt ps ps', HIsAscList lt ps' b) => HIsSetBy lt ps b+++-- | @HAscList le xs@ confirms that xs is in ascending order,+-- and reports which element is duplicated otherwise.+class HEqByFn le => HAscList le (ps :: [*])++instance (HEqByFn le, HAscList0 le ps ps) => HAscList le ps++class HEqByFn le => HAscList0 le (ps :: [*]) (ps0 :: [*])++class HEqByFn le => HAscList1 le (b :: Bool) (ps :: [*]) (ps0 :: [*])+instance ( HAscList1 le b (y ': ys) ps0, HEqBy le x y b+#if __GLASGOW_HASKELL__ > 906+         , HEqByFn le+#endif+         )+  => HAscList0 le (x ': y ': ys) ps0+instance HEqByFn le => HAscList0 le '[] ps0+instance HEqByFn le => HAscList0 le '[x] ps0++instance ( Fail '("Duplicated element", y, "using le", le, "in", ys0), HEqByFn le )+    => HAscList1 le False (y ': ys) ys0+instance HAscList0 le ys ys0 => HAscList1 le True ys ys0++{- $setup++>>> import Data.HList.TypeEqO++-}
+ hlist/Data/HList/HTypeIndexed.hs view
@@ -0,0 +1,81 @@++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Type-indexed operations on typeful heterogeneous lists.+-}++module Data.HList.HTypeIndexed where++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import Data.HList.HList+import Data.HList.HArray+import Data.HList.HOccurs ()++-- --------------------------------------------------------------------------+-- | Map a type to a natural (index within the collection)+-- This is a purely type-level computation++instance (HEq e1 e b, HType2HNatCase b e1 l n) => HType2HNat e1 (e ': l) n++-- | Helper class+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 => proxy1 e -> proxy l -> Proxy n+hType2HNat _ _ = Proxy++-- | And lift to the list of types++instance HTypes2HNats ('[] :: [*]) (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 _ _ = Proxy++-- --------------------------------------------------------------------------+-- Implementing the generic interfaces++instance HDeleteMany e (HList '[]) (HList '[]) where+  hDeleteMany _ HNil = HNil++instance (HEq e1 e b, HDeleteManyCase b e1 e l l1)+      => HDeleteMany e1 (HList (e ': l)) (HList l1) where+  hDeleteMany p (HCons e l) =+      hDeleteManyCase (Proxy :: Proxy b) p e l++class HDeleteManyCase (b :: Bool) e1 e l l1 | b e1 e l -> l1 where+  hDeleteManyCase :: Proxy b -> Proxy e1 -> e -> HList l -> HList l1++instance HDeleteMany e (HList l) (HList l1) => HDeleteManyCase True e e l l1+ where+  hDeleteManyCase _ p _ l = hDeleteMany p 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 p l = hDeleteAtHNat (hType2HNat p l) l++hUpdateAt e l = hUpdateAtHNat (hType2HNat (Just e) l) e l++hProjectBy ps l = hProjectByHNats (hTypes2HNats ps l) l++hSplitBy ps l = hSplitByHNats (hTypes2HNats ps l) l+++-- | should this instead delete the first element of that type?+instance (HDeleteAtHNat n l, HType2HNat e l n, l' ~ HDeleteAtHNatR n l)+      => HDeleteAtLabel HList e l l' where+    hDeleteAtLabel _ = hDeleteAtHNat (Proxy :: Proxy n)
+ hlist/Data/HList/HZip.hs view
@@ -0,0 +1,109 @@++{- |+   The HList library++   (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.HList+import Data.HList.FakePrelude++-- * zip+-- ** functional dependency++-- $note1 moved to "Data.HList.HList" to avoid an orphan instance++-- ** type family+-- $note 'hZip2' can be written as a standalone function, with an appropriate+-- 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.++-- | HZipR in the superclass constraint doesn't hurt, but it doesn't seem to be+-- necessary+class HZipR (MapFst z) (MapSnd z) ~ z => HUnZip z where+  type MapFst z :: [*]+  type MapSnd z :: [*]+  hZip2 :: HList (MapFst z) -> HList (MapSnd z) -> HList z+  hUnzip2 :: HList z -> (HList (MapFst z), HList (MapSnd z))++instance HUnZip '[] where+  type MapFst '[] = '[]+  type MapSnd '[] = '[]+  hZip2 _ _ = HNil+  hUnzip2 _ = (HNil, HNil)++instance (z ~ (x,y), HUnZip zs) => HUnZip (z ': zs) where+  type MapFst (z ': zs) = ( Fst z ': MapFst zs )+  type MapSnd (z ': zs) = ( Snd z ': MapSnd zs )+  hZip2 (HCons x xs) (HCons y ys) = HCons (x,y) (hZip2 xs ys)+  hUnzip2 (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip2 zs in (x `HCons` xs, y `HCons` ys)+++-- | 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+++-- * transpose++{- | 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++-- | 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 HZip3 '[] '[] '[] where+  hZip3 _ _ = HNil++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
+ hlist/Data/HList/Keyword.hs view
@@ -0,0 +1,673 @@++{- | Description: keyword arguments++The public interface is exposed in <Data-HList-CommonMain.html#t:Kw CommonMain#Kw>++-}+module Data.HList.Keyword (++  -- * main+  Kw(..),+  IsKeyFN,++  recToKW,++  -- ** another label type+  K(..),++  -- * types for user error+  ErrReqdArgNotFound,+  ErrUnexpectedKW,+++  -- * demo+  -- ** setup data types+  -- $setup+  -- $ex2++  -- * Implementation details+  -- $imploutline+  KWApply(..),+  KWApply'(..),+  Arg(..),++++  -- ** producing lists from a function's arguments+  reflect_fk,+  ReflectFK,+  ReflectFK',+++  -- ** collecting arguments+  KW(..),+  KW'(..),+  KWAcc(..),++  -- ** merging default with supplied arguments+  KWMerge(..),+  KWMerge'(..),+  KWMerge''(..),++  HDelete, HDelete',+++  -- * original introduction+  -- $originalIntro+++  -- * todo+  -- $todo++  -- * internal for type signature prettiness+  TaggedToKW,+  ) where++import GHC.TypeLits+import Data.HList.FakePrelude+import Data.HList.TypeEqO+import Data.HList.HListPrelude+import Data.HList.HList+import Data.HList.Record++{- $setup++ >>> :set -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses+ >>> :set -XScopedTypeVariables -XOverlappingInstances -XTypeFamilies+ >>> :set -fcontext-stack=100++We will be using an example inspired by a graphics toolkit -- the area+which really benefits from keyword arguments. We first define our+labels and useful datatypes++ >>> data Color = Color+ >>> data Size  = Size+ >>> data Origin  = Origin+ >>> data RaisedBorder = RaisedBorder+++The number of arguments each keyword must be specified by an 'IsKeyFN'+instance.++ >>> instance IsKeyFN (Color->a->b)  True+ >>> instance IsKeyFN (Size->a->b)   True+ >>> instance (a ~ (Int,Int)) => IsKeyFN (Origin->a->b) True+ >>> instance IsKeyFN (RaisedBorder->a->b) True++Note that if a keyword is always followed by a certain type, that+can be specified above using an instance like the one for Origin.++ >>> data CommonColor = Red | Green | Blue deriving Show+ >>> data RGBColor = RGBColor Int Int Int deriving Show++and two functions:++ >>> :{+ let make_square Size n Origin (x0,y0) Color (color::CommonColor) =+        unwords ["Square:", show (n :: Int), "at", show (x0,y0), show color] ++ "\n"+ :}++ >>> :{+ let make_rect Size (nx,ny) Origin (x0,y0) Color (color::RGBColor)+         RaisedBorder border =+        unwords ["Rectangle:", show (nx,ny), "at", show (x0,y0),+             show color, if border then "raised border" else ""] ++ "\n"+ :}++-}++{- $ex2++We are not interested in really drawing squares and rectangles+here. Therefore, make_square and make_rect return a String, which we+can regard as a ``command'' to be passed to a low-level graphics+library. The functions make_square and make_rect are genuine functions+and can be used as such. They are not keyword argument functions, yet,+but they set the stage. These functions can be considered an+`interface' for the keyword argument functions. We should note that+the functions are polymorphic: for example, `Size' can be any+showable. We must also emphasize the re-use of the labels: The Color+of a square is the value of the enumerated type CommonColor. OTH, the+color of the rectangle is given as an RGB triple. The sizes of the+square and of the rectangle are specified differently too, the same+label notwithstanding.++Once the user wrote the functions such as make_square and make_rect,+he can _automatically_ convert them to their keyword+alternatives. This transformation is done by a function 'kw'. The user+should pass the positional-argument function (`labeled' as above),+and an HList of default values for some of the labels. The latter may+be HNil if all keyword arguments are required.++The first example (no defaults)++ >>> kw (make_square .*. HNil) Size (1::Int) Origin (0,10) Color Red   :: String+ "Square: 1 at (0,10) Red\n"++we can permute the arguments at wish++ >>> kw (make_square .*. HNil) Color Red Size (1::Int) Origin (0,10)   :: String+ "Square: 1 at (0,10) Red\n"++we can also assign a name to a keyword function, or partially apply it:++ >>> :{+ case kw (make_square .*. HNil) Color Red of+    f -> "here: " ++ f Origin (0,10) Size (1::Int)+:}+"here: Square: 1 at (0,10) Red\n"++Note that it is necessary to use a monomorphic pattern binding here (lambda or+case). One way to get around this is to pass @f@ instead of @kw f@ around:++>>> :{+ let f = hEnd $ hBuild make_square Color Red+ in "here: " ++ kw f Origin (0,10) Size (1::Int)+:}+"here: Square: 1 at (0,10) Red\n"++The following is a more interesting example, with the+defaults:++ >>> :{+let addDef f = f .*. Origin .*. (0,10) .*.+             RaisedBorder .*. True .*.+             HNil+    in kw (addDef make_square) Size (1::Int) Color Red +++       kw (addDef make_rect)   Color (RGBColor 0 10 255)+                               Size (1.0::Float, 2.0::Float)+:}+"Square: 1 at (0,10) Red\nRectangle: (1.0,2.0) at (0,10) RGBColor 0 10 255 raised border\n"++The argument RaisedBorder is not given, and so the default value is+used. Of course, we can override the default:++ >>> :{+let addDef f =  f .*. Origin .*. (0,10) .*.+                    RaisedBorder .*. True .*.+                    HNil+ in case kw (addDef make_square) Color of+     sq -> case kw (addDef make_rect)  of+      re ->+         sq Red Size (1::Int) +++         re Color (RGBColor 0 10 255)+             RaisedBorder False+             Size (1.0::Float, 2.0::Float)+:}+"Square: 1 at (0,10) Red\nRectangle: (1.0,2.0) at (0,10) RGBColor 0 10 255 \n"++We have reshuffled a few arguments, just for fun. As you can see, the+function `kw make_rect defaults' is polyvariadic indeed.  We chose to+partially apply 'Color' to the function `kw make_square defaults' --+so that the function `sq' is positional in its first argument, and+keyword in the rest.++If we omit a required argument, we get a type error:++> ] testse1 = let f x = kw make_square HNil Color Red x+> ]         in "here: " ++ f Origin (0,10)+>+>   Couldn't match `ErrReqdArgNotFound Size' against `[Char]'+>       Expected type: ErrReqdArgNotFound Size+>       Inferred type: [Char] ...++The error message seems reasonably clear. Likewise we get an error+message if we pass to a keyword function an argument it does not expect:++> ] testse2 = let f x = kw make_square HNil Color Red x+> ]         in "here: " ++ f Origin (0,10) Size (1::Int)+> ]                       RaisedBorder False+>+>   No instances for (Fail (ErrUnexpectedKW RaisedBorder),+>             KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char])+>       arising from use of `f' at ...+>     In the second argument of `(++)', namely+>   `f Origin (0,10) Size (1 :: Int) RaisedBorder False'+++The function 'kw' receives the appropriately labeled function (such+as make_square) and the HList with default values. The function 'kw'+is polymorphic; the overloading is resolved based on the type of the+user function *and* on the type of its continuation. The continuation+indicates if a keyword argument is forthcoming, or not. In the latter+case, 'kw' checks to see if the supplied defaults can provide the+values of the still missing arguments. We see therefore that a+function type is more than it may appear -- the type of a function is+truly a heterogeneous, type level collection! The function 'kw'+traverses that collection, thus performing a limited form of+reflection on Haskell functions.++-}+++{- $imploutline++One of the key tools of the implementation is 'kwapply', which applies+a function to a polymorphic collection of that function's arguments.+The order of the arguments in the collection is irrelevant. The+contraption kwapply can handle polymorphic functions with arbitrary+number of labeled arguments.++For example, if we define++> f1 Size n = show n+> f2 Size n Color m = unwords ["size:", show n, "color:", show m]+> f3 Origin x Color m Size n =+>     unwords ["origin:", show x, "size:", show n, "color:",show m]++then we can run++> katest1  = kwapply f1 (Size .*. () .*. HNil)+> katest11 = kwapply f1 (Size .*. "Large" .*. HNil)+>+> katest2  = kwapply f2 (Size .*. (1::Int) .*. Color .*. Red .*. HNil)+> katest21 = kwapply f2 (Color .*. Red .*. Size .*. (1::Int) .*.  HNil)+>+> katest3  = kwapply f3 (Size .*. (1::Int) .*. Origin .*. (2.0::Float) .*.+>                  Color .*. Red .*. HNil)++-}+++-- | Another key contraption is++reflect_fk:: (ReflectFK fn kws) => fn -> Arg kws '[]+reflect_fk _ = Arg HNil++{- ^++that reflects on a user-supplied function. It converts the *type* of a+user function to a collection of keywords required by that+function. This and the previous contraptions may be used to define an+`extended' version of some user function that takes more arguments --+without the need to enumerate all arguments of the original+function. We thus infringe on the area of object and module systems.++The rest of the implementation is just to convert `kw fn defaults'+into the application of kwapply.++-}+++-- * The rest of the implementation+{- $impl++We should note that all implementation is written in the+continuation-passing style (CPS) -- at the term level and especially+at the _typeclass level_. One of the reasons is to avoid relying on+overlapping instances: we compare types with a predicate `TypeEq x y+hbool', obtain the type-level boolean, and dispatch to two+non-overlapping instances of an auxiliary, continuation class. One+instance handles HTrue, and the other the HFalse alternative. Please+see the HList paper for more discussion of this technique.++The other, equally important reason for the thorough CPS of the+typeclasses is to control the order of evaluation of constraints and+their functional dependencies. The sole reason is to produce+informative error messages. The order of constraints is irrelevant+when all the constraints are satisfied. However, if the user omitted a+required keyword, many of the constraints below will fail. If a+'wrong' constraint fails first, we get a totally off-the-wall error+message that gives us no clue whatsoever about the problem. By tightly+constraining the order via CPS, we are able to force the typechecker+to give informative error messages.++-}++++-- * Errors++data ErrReqdArgNotFound x+data ErrUnexpectedKW x+++instance IsKeyFN (Label (s :: Symbol) -> a -> b) True+{- ^ labels that impose no restriction on the type of the (single) argument+ which follows++ >>> let testF (_ :: Label "a") (a :: Int) () = a+1+ >>> kw (hBuild testF) (Label :: Label "a") 5 ()+ 6++-}++{- | The purpose of this instance is to be able to use the same Symbol+ (type-level string) at different types. If they are supposed to be the same,+ then use 'Label' instead of 'K'++ >>> let kA = K :: forall t. K "a" t+ >>> let testF (K :: K "a" Int) a1 (K :: K "a" Integer) a2 () = a1-fromIntegral a2++ therefore the following options works:++ >>> kw (hBuild testF) kA (5 :: Int) kA (3 :: Integer) ()+ 2++ >>> kw (hBuild testF) (K :: K "a" Integer) 3 (K :: K "a" Int) 5 ()+ 2++ But you cannot leave off all @Int@ or @Integer@ annotations.++-}+instance (r ~ (c -> b)) => IsKeyFN ( (K s c) -> r) True++data K s (c :: *) = K+++-- * The implementation of KWApply++class KWApply f arg_values r where+    kwapply:: f -> HList arg_values -> r++instance (r ~ r') => KWApply r '[] r' where+    kwapply f _ = f++instance (HEq kw kw' flag,+      KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r)+    => KWApply (kw ->a->f') (kw' ': a' ': tail) r where+    kwapply = kwapply' (Proxy :: Proxy flag)++class KWApply' flag f arg_values r  where+    kwapply':: Proxy flag -> f -> HList arg_values -> r++instance  (v' ~ v, KWApply f' tail r)+    => KWApply' True (kw->v->f') (kw ': v' ': tail) r where+    kwapply' _ f (HCons kw_ (HCons v' tl)) =+                   kwapply (f kw_ v') tl++-- | Rotate the arg list ...+instance  (HAppendListR tail '[kw , v] ~ l',+           HAppendList tail '[kw, v],+       KWApply f l' r)+    => KWApply' False f (kw ': v ': tail) r where+    kwapply' _ f (HCons kw_ (HCons v tl)) =+      kwapply f (hAppend tl (kw_ .*. v .*. HNil))++{- |++The datatype Arg below is to maintain the state of keyword+accumulation: which keywords we need, and which keyword and values we+have already got.+arg_types is the phantom HList of keywords that are yet to be satisfied.+arg_values is the @HList (kw .*. kw_value .*. etc)@+of already found keywords and their values.+-}++newtype Arg arg_types arg_values = Arg (HList arg_values)+deriving instance Show (HList vals) => Show (Arg tys vals)++{- | Reflection on a function:+Given a function, return the type list of its keywords++>>> :t reflect_fk (undefined::Size->Int->Color->CommonColor->String)+reflect_fk (undefined::Size->Int->Color->CommonColor->String)+  :: Arg '[Size, Color] '[]++>>> :t reflect_fk (undefined::Size->Int->()->Int)+reflect_fk (undefined::Size->Int->()->Int) :: Arg '[Size] '[]+++-}++class ReflectFK f (kws :: [*])+instance (IsKeyFN f flag, ReflectFK' flag f kws) => ReflectFK f kws+class ReflectFK' (flag :: Bool) f kws+instance (kkws ~ (kw ': kws), ReflectFK rest kws) => ReflectFK' True (kw->a->rest) kkws+instance ('[] ~ nil) => ReflectFK' False f nil+++-- | The main class: collect and apply the keyword arguments++class KW f arg_desc arg_def r where+    kwdo :: f -> arg_desc -> HList arg_def -> r++instance (IsKeyFN r rflag,+        KW' rflag f arg_desc arg_def r)+    => KW f arg_desc arg_def r where+    kwdo = kw' (Proxy ::Proxy rflag)++class KW' rflag f arg_desc arg_def r where+    kw' :: Proxy rflag -> f -> arg_desc -> HList arg_def -> r++{- |+If the continuation r does not promise any more keyword+arguments, apply the defaults -}++instance KWMerge arg_needed arg_values arg_def f r+    => KW' False f (Arg arg_needed arg_values) arg_def r where+    kw' _ f args_given arg_def = kwmerge args_given arg_def f++{- | Otherwise, collect the supplied keyword and its value, and recurse for+more: -}++instance (KWAcc arg_desc kw a f arg_def r, (kw->a->r) ~ kwar)+    => KW' True f arg_desc arg_def kwar where+    kw' _ f arg_desc arg_def kw_ a = kwaccum arg_desc kw_ a f arg_def+++{- | Add the needed arguments from arg_def to arg_values and continue+with kwapply.++That is, we try to satisfy the missing arguments from the defaults.+It will be a type error if some required arguments are missing -}++class KWMerge arg_needed arg_values arg_def f r where+    kwmerge:: Arg arg_needed arg_values -> HList arg_def -> f -> r++instance KWApply f arg_values r+    => KWMerge '[] arg_values arg_def f r where+    kwmerge (Arg arg_values) _ f = kwapply f arg_values++instance KWMerge' kw arg_def atail arg_values arg_def f r+    => KWMerge (kw ': atail) arg_values arg_def f r where+    kwmerge (Arg arg_values) arg_def =+      kwmerge' (undefined :: kw) arg_def+             ((Arg arg_values)::Arg atail arg_values) arg_def++class KWMerge' kw list atail arg_values arg_def f r where+    kwmerge':: kw -> HList list -> (Arg atail arg_values) -> HList arg_def -> f -> r++instance (Fail (ErrReqdArgNotFound kw), nff ~ (ErrReqdArgNotFound kw))+    => KWMerge' kw '[] atail arg_values arg_def f+                nff where+    kwmerge' = undefined+instance (HEq kw kw' flag,+      KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r)+    => KWMerge' kw (kw' ': etc) atail arg_values arg_def f r where+    kwmerge' = kwmerge'' (Proxy :: Proxy flag)++class KWMerge'' (flag :: Bool) kw (list :: [*]) atail arg_values arg_def f r+     where+    kwmerge'':: Proxy flag -> kw -> HList list+        -> Arg atail arg_values -> HList arg_def+        -> f -> r+instance KWMerge atail (kw ': v ': arg_values) arg_def f r+    => KWMerge'' True kw (kw ': v ': tail)+                 atail arg_values arg_def f r where+    kwmerge'' _ _ (HCons kw_ (HCons v _)) (Arg arg_values) =+      kwmerge ((Arg (kw_ .*. v .*. arg_values))::+         (Arg atail (kw ': v ': arg_values)))+instance KWMerge' kw tail atail arg_values arg_def f r+    => KWMerge'' False kw (kw' ': v' ': tail)+                 atail arg_values arg_def f r where+    kwmerge'' _ kw_ (HCons _ (HCons _ tl)) = kwmerge' kw_ tl++-- | Add the real argument to the Arg structure, and continue++class KWAcc arg_desc kw a f arg_def r where+    kwaccum:: arg_desc -> kw -> a -> f -> HList arg_def -> r+++instance (HDelete kw arg_types arg_types',+      KW f (Arg arg_types' (kw ': a ': arg_values)) arg_def r)+    => KWAcc (Arg arg_types arg_values) kw a f arg_def r  where+    kwaccum (Arg arg_values) kw_ a f =+      kwdo f (Arg (kw_ .*. a .*. arg_values)::+        Arg arg_types' (kw ': a ': arg_values))+++-- | Delete e from l to yield l' The element e must occur in l++class HDelete e (l :: [k]) (l' :: [k])+instance (Fail (ErrUnexpectedKW e), r ~ '[]) => HDelete e '[] r+instance (HEq e e' flag, HDelete' flag e (e' ': tail) l')+    => HDelete e (e' ': tail) l'+class HDelete' (flag :: Bool) e l l'+instance (tail' ~ tail) => HDelete' True e (e ': tail) tail'+instance (HDelete e tail tail', e'tail ~ (e' ': tail'))+    => HDelete' False e (e' ': tail) e'tail+++{- |++@kw@ takes a 'HList' whose first element is a function, and the rest+of the elements are default values.+A useful trick is to have a final argument @()@ which is not+eaten up by a label (A only takes 1 argument). That way when you supply+the () it knows there are no more arguments (?).++>>> data A = A+>>> instance IsKeyFN (A -> a -> b) True+>>> let f A a () = a + 1+>>> let f' = f .*. A .*. 1 .*. HNil++>>> kw f' A 0 ()+1++>>> kw f' ()+2++-}+class Kw (fn :: *) (arg_def :: [*]) r where+    kw :: HList (fn ': arg_def) -> r++instance+    (KW' rflag fn akws arg_def r,+     akws ~ (Arg (kws :: [*]) '[]),+     ReflectFK' flag fn kws, IsKeyFN r rflag,+     IsKeyFN fn (flag::Bool)) => Kw fn arg_def r+   where+    kw (HCons f arg_def) = kwdo f rfk arg_def :: r+        where rfk = reflect_fk f :: akws++data TaggedToKW = TaggedToKW+instance (x ~ Tagged l v, y ~ HList '[Label l, v]) =>+        ApplyAB TaggedToKW x y where+    applyAB _ (Tagged v) = hBuild Label v+++{- | convert a 'Record' into a list that can supply+default arguments for 'kw'++A bit of setup:++>>> :set -XQuasiQuotes+>>> import Data.HList.RecordPuns+>>> let f (_ :: Label "a") a (_ :: Label "b") b () = a `div` b+++>>> let a = 2; b = 1; f' = f .*. recToKW [pun| a b |]+>>> kw f' ()+2++>>> kw f' (Label :: Label "a") 10 ()+10+++-}+recToKW :: forall a b. (HMapCxt HList TaggedToKW a b, HConcat b) =>+     Record a -> HList (HConcatR b)+recToKW (Record r) = hConcat (hMap TaggedToKW r :: HList b)++{- $originalIntro++> From oleg-at-okmij.org Fri Aug 13 14:58:35 2004+> To: haskell@haskell.org+> Subject: Keyword arguments+> From: oleg-at-pobox.com+> Message-ID: <20040813215834.F1FF3AB7E@Adric.metnet.navy.mil>+> Date: Fri, 13 Aug 2004 14:58:34 -0700 (PDT)+> Status: OR+++We show the Haskell implementation of keyword arguments, which goes+well beyond records (e.g., in permitting the re-use of+labels). Keyword arguments indeed look just like regular, positional+arguments. However, keyword arguments may appear in any+order. Furthermore, one may associate defaults with some keywords; the+corresponding arguments may then be omitted. It is a type error to+omit a required keyword argument. The latter property is in stark+contrast with the conventional way of emulating keyword arguments via+records. Also in marked contrast with records, keyword labels may be+reused throughout the code with no restriction; the same label may be+associated with arguments of different types in different+functions. Labels of Haskell records may not be re-used.  Our solution+is essentially equivalent to keyword arguments of DSSSL Scheme or+labels of OCaml.++Keyword argument functions are naturally polyvariadic: Haskell does+support varargs! Keyword argument functions may be polymorphic. As+usual, functions with keyword arguments may be partially applied. On+the downside, sometimes one has to specify the type of the return+value of the function (if the keyword argument function has no+signature -- the latter is the norm, see below) -- provided that the+compiler cannot figure the return type out on its own. This is usually+only the case when we use keyword functions at the top level (GHCi+prompt).++Our solution requires no special extensions to Haskell and works with+the existing Haskell compilers; it is tested on GHC 6.0.1. The+overlapping instances extension is not necessary (albeit it is+convenient).++The gist of our implementation is the realization that the type of a+function is a polymorphic collection of its argument types -- a+collection that we can traverse. This message thus illustrates a+limited form of the reflection on a function.+++Our implementation is a trivial extension of the strongly-typed+polymorphic open records described in+    <http://homepages.cwi.nl/~ralf/HList/>++In fact, the implementation relies on the HList library.  To run the+code (which this message is), one needs to download the HList library+from the above site.++The HList paper discusses the issue of labels in some detail. The+paper gives three different representations. One of them needs no+overlapping instances and is very portable. In this message, we chose+a representation that relies on generic type equality and therefore+needs overlapping instances as implemented in GHC. Again, this is+merely an outcome of our non-deterministic choice. It should be+emphasized that other choices are possible, which do not depend on+overlapping instances at all. Please see the HList paper for details.++-}+++{- $todo++[@better instances for Symbol@]++There isn't a pair @(K2 \"Origin\" (Int, Int))@ @(K \"hi\")@ that behaves just like Origin below.+something is possible between constraintkinds. See 'Data.HList.FakePrelude.Fun'++> instance (a ~ (Int,Int)) => IsKeyFN (Origin->a->b) True++[@wildcard/catchall@]++like in R. This would be a special keyword for keyword args that didn't match.+They would be put in a HList/Record argument like @...@++[@investigate first-classness of varargs@]+for whatever reason you can't have  @f = kw fn blah@ and then pass more arguments+on to fn. This is bad. It used to work (in the ghc6.0 days and probably up to+6.12). Some convenience functions/operators should be added which do the same+thing as:++> fn `hAppendList` hBuild a b c d e+++-}
+ hlist/Data/HList/Label3.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE CPP #-}++{- |++   Description : namespaced labels++   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 description is 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 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+   equality.+-}++module Data.HList.Label3 where++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import GHC.TypeLits++{- $setup++>>> let label3 = Label :: Label (Lbl HZero () ())+>>> let label6 = Label :: Label "6"++-}++data Lbl (x :: HNat) (ns :: *) (desc :: *)  -- labels are exclusively type-level entities+#if OLD_TYPEABLE+instance (ShowLabel x) => Typeable2 (Lbl x) where+  typeOf2 _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Label3" "Lbl")+    [mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label x)))+      []]+#endif++type instance ZipTagged (Lbl ix ns n ': ts) (v ': vs) = Tagged (Lbl ix ns n) v ': ZipTagged ts vs++instance (Label t ~ Label (Lbl ix ns n)) => SameLabels (Label t) (Lbl ix ns n)++-- * Public constructors for labels++-- | Construct the first label+firstLabel :: ns -> desc -> Label (Lbl HZero ns desc)+firstLabel _ _ = Label+++-- | Construct the next label+nextLabel :: Label (Lbl x ns desc) -> desc' -> Label (Lbl (HSucc x) ns desc')+nextLabel _ _ = Label+++-- | Equality on labels (descriptions are ignored)+-- Use generic instance+{-+instance ( HEq x x' b+         , HEq ns ns' b'+         , bres ~ HAnd b b'+         )+      =>   HEq (Lbl x ns desc) (Lbl x' ns' desc') bres+-}++-- | Show label++instance Show desc => ShowLabel (Lbl x ns desc) where+  showLabel = show . getd+      where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs+            getd = error "Data.HList.Label3 desc"++instance Show desc => Show (Label (Lbl x ns desc))+ where+  show = show . getd+      where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs+            getd = error "Data.HList.Label3 desc"++++{- |++If possible, Label is left off:++>>> let q = label3 .*. label3 .*. emptyProxy+>>> :t q+q :: Proxy '[Lbl 'HZero () (), Lbl 'HZero () ()]++-}+instance HExtend (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs)) where+    type HExtendR (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs))+                = Proxy (Lbl n ns desc ': Lbl n' ns' desc' ': xs)+    (.*.) _ _ = Proxy++{- | Mixing two label kinds means we have to include 'Label':++>>> let r = label3 .*. label6 .*. emptyProxy+>>> :t r+r :: Proxy '[Label (Lbl 'HZero () ()), Label "6"]++-}+instance HExtend (Label (Lbl n ns desc)) (Proxy (x ': xs :: [Symbol])) where+    type HExtendR (Label (Lbl n ns desc)) (Proxy (x ': xs))+              = Proxy (Label (Lbl n ns desc) ': MapLabel (x ': xs))+    (.*.) _ _ = Proxy++{- | Mixing two label kinds means we have to include 'Label':++>>> let s = label6 .*. label3 .*. emptyProxy+>>> :t s+s :: Proxy '[Label "6", Label (Lbl 'HZero () ())]++-}+instance HExtend (Label (y :: Symbol)) (Proxy ((x :: *) ': xs)) where+    type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Symbol)) (Proxy ((x :: Nat) ': xs)) where+    type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Nat)) (Proxy ((x :: *) ': xs)) where+    type HExtendR (Label (y :: Nat)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Nat)) (Proxy ((x :: Symbol) ': xs)) where+    type HExtendR (Label (y :: Nat)) (Proxy (x ': xs))+          = Proxy (Label y ':  (MapLabel (x ': xs)))+    (.*.) _ _ = Proxy++-- | similar to Data.HList.Record.Labels1, but avoids producing Label (Label x)+type family MapLabel (xs :: [k]) :: [*]+type instance MapLabel '[] = '[]+#if NO_CLOSED_TF+-- if we can't have any overlap in the TF (ghc-7.6), cover the Label3/Label6 case+type instance MapLabel ((x :: Symbol) ': xs) = Label x ': MapLabel xs+type instance MapLabel (Lbl n ns desc ': xs) = Label (Lbl n ns desc) ': MapLabel xs+type instance MapLabel (Label x ': xs) = Label x ': MapLabel xs+#else+type instance MapLabel (x ': xs) = AddLabel x ': MapLabel xs+type family AddLabel (x :: k) :: * where+  AddLabel (Label x) = Label x+  AddLabel x = Label x+#endif
+ hlist/Data/HList/Label5.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif+#if __GLASGOW_HASKELL__ > 906+{-# LANGUAGE LambdaCase #-}+#endif+{- |+   Description: labels are any instance of Typeable++   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Yet another model of labels.++   This model allow us to use any type as label type.+   As a result, we need some generic instances.++   Also, type errors may be more confusing now.+-}++module Data.HList.Label5 where++import Data.Typeable+import Data.Char+import Data.HList.FakePrelude+++-- | Equality on labels++-- instance TypeEq x y b => HEq x y b+++-- | Show label+instance {-# OVERLAPPABLE #-} Typeable (x :: *) => ShowLabel x+ where+  showLabel _ = (\l -> case l of [] -> [] ; (x:xs) -> toLower x:xs)+            . reverse+            . takeWhile (not . (==) '.')+            . reverse+            . show+{-+            . tyConString+            . typeRepTyCon+-}+            . typeOf $ (error "Data.HList.Label5 has a strict typeOf" :: x)
+ hlist/Data/HList/Label6.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+{- |+   Description : labels using promoted strings (Symbol)++   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke+++   Yet another model of labels.++   Labels are promoted Strings or Integers "GHC.TypeLits" inside the+   'Label'. Needs ghc7.6 or higher.++   See <Data-HList-CommonMain.html#label6demo CommonMain#label6demo> for an example.++-}++module Data.HList.Label6 () where++import Data.HList.FakePrelude+import GHC.TypeLits+import Data.HList.HListPrelude++#if MIN_VERSION_base(4,7,0)+instance KnownSymbol x => ShowLabel (x :: Symbol) where+  showLabel _ =  symbolVal (Proxy :: Proxy x)+instance KnownNat x => ShowLabel (x :: Nat) where+  showLabel _ =  show $ natVal (Proxy :: Proxy x)+#else+instance SingI x => ShowLabel (x :: Symbol) where+  showLabel _ =  fromSing (sing :: Sing x)++instance SingI x => ShowLabel (x :: Nat) where+  showLabel _ =  show (fromSing (sing :: Sing x))+#endif++++{- |++>>> let labelX = Label :: Label "x"+>>> let labelY = Label :: Label "y"+>>> let p = labelX .*. labelY .*. emptyProxy+>>> :t p+p :: Proxy '["x", "y"]++-}+instance HExtend (Label (y :: Symbol)) (Proxy (x ': xs :: [Symbol])) where+    type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs)+    (.*.) _ _ = Proxy++instance HExtend (Label (y :: Nat)) (Proxy (x ': xs :: [Nat])) where+    type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs)+    (.*.) _ _ = Proxy
+ hlist/Data/HList/Labelable.hs view
@@ -0,0 +1,355 @@+{- |++Description : labels which are also lenses (or prisms)++A simple problem is being solved here, but unfortunately it+is a bit involved. The idea is to use the same haskell identifier+for a lens and for other purposes. In other words, get the same+behavior as:++ > x = hLens (Label :: Label "x")+ > r ^. x++While still being able to extract the symbol \"x\" from x, so that things+like @x .=. 123@ could be acceptable. In this case we don't overload '.=.',+so instead you have to write @x .==. 123@.+++Elaboration of some ideas from edwardk.+-}+module Data.HList.Labelable+    (Labelable(..),+     LabeledOptic,+     (.==.),+++     -- * multiple lookups+     Projected(..), projected',++    -- * comparison with 'hLens'+    -- $comparisonWithhLensFunction++    -- * likely unneeded (re)exports+    LabeledCxt1,+    LabeledTo(LabeledTo),+    LabeledR(LabeledR),+    ToSym, EnsureLabel(toLabel), toLabelSym,+    Identity,+    LabelableTIPCxt,+    LabeledOpticType(..),++    LabeledOpticF,+    LabeledOpticP,+    LabeledOpticTo,+    ) where++++import Data.HList.HListPrelude+import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.Variant+import Data.HList.TIP+import Data.HList.TIC+import Data.HList.Label3++import Control.Monad.Identity+import GHC.TypeLits+import LensDefs+import GHC.Exts (Constraint)++{- | This alias is the same as Control.Lens.Optic, except the (->) in Optic+is a type parameter 'to' in LabeledOptic.++Depending on the collection type (see instances of 'LabelableTy'),+the type variables @to, p, f@ are constrained such that the resulting+type is a @Lens (r s) (r t) a b@, @Prism (r s) (r t) a b@ or a+@LabeledTo x _ _@. The latter can be used to recover the label (@x@) when+used as an argument to '.==.' or equivalently 'toLabel'.+-}+type LabeledOptic (x :: k) (r :: [*] -> *) (s :: [*]) (t :: [*]) (a :: *) (b :: *)+    = forall ty to p f.+                     (ty ~ LabelableTy r,+                      LabeledOpticF ty f,+                      LabeledOpticP ty p,+                      LabeledOpticTo ty x to) => (a `p` f b) `to` (r s `p` f (r t))++data LabeledOpticType = LabelableLens | LabelablePrism | LabelableLabel++type family LabeledOpticF (ty :: LabeledOpticType) :: (* -> *) -> Constraint+type instance LabeledOpticF LabelableLens = Functor+type instance LabeledOpticF LabelablePrism = Applicative+type instance LabeledOpticF LabelableLabel = (~) Identity++type family LabeledOpticP (ty :: LabeledOpticType) :: (* -> * -> *) -> Constraint+type instance LabeledOpticP LabelableLens = (~) (->)+type instance LabeledOpticP LabelablePrism = Choice+type instance LabeledOpticP LabelableLabel = (~) (->)++type family LabeledOpticTo (ty :: LabeledOpticType) (x :: k) :: (* -> * -> *) -> Constraint+type instance LabeledOpticTo LabelableLens x = (~) (->)+type instance LabeledOpticTo LabelablePrism x = (~) (->)+type instance LabeledOpticTo LabelableLabel x = (~) (LabeledTo x)+++{- |++[@r@] is 'Record', 'Variant'. 'TIP' and 'TIC' also have instances, but generally+'tipyLens'' and 'ticPrism'' are more appropriate.++[@x@] is the label for the field. It tends to have kind 'GHC.TypeLits.Symbol',+but others are supported in principle.++-}+class SameLength s t => Labelable (x :: k) (r :: [*] -> *) s t a b+          | x s -> a, x t -> b,    -- lookup+            x s b -> t, x t a -> s -- update+  where+    type LabelableTy r :: LabeledOpticType+    hLens' :: Label x -> LabeledOptic x r s t a b++data LabeledTo (x :: k) (a :: *) (b :: *) = LabeledTo deriving (Show)++data LabeledR (x :: [*]) = LabeledR++{- if __GLASGOW_HASKELL__ > 800+-- should this orphan instance really be supplied? ghc 8's+-- -XOverloadedLabels is uglier syntax than HListPP, and it+-- seems likely that other users of IsLabel probably define+-- an instance for (->) which will be chosen over this one+-- when labels are composed with (.),+-- (or alternatively there will be complaints about overlap)+instance (x ~ x', Labelable x r s t a b) => IsLabel x (LabeledOptic x' r s t a b) where+    fromLabel _ = hLens' (Label :: Label x)+-- endif+-}+++-- | make a @Lens (Record s) (Record t) a b@+instance HLens x Record s t a b+        => Labelable x Record s t a b where+            type LabelableTy Record = LabelableLens+            hLens' x = hLens x++-- | used with 'toLabel' and/or '.==.'+instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where+        type LabelableTy LabeledR = LabelableLabel+        hLens' _ = LabeledTo++-- | sets all type variables to dummy values: only the @Labeled x@+-- part is actually needed+type LabeledCxt1 s t a b = (s ~ '[], t ~ '[], a ~ (), b ~ ())++-- | make a @Prism (Variant s) (Variant t) a b@+instance (HPrism x s t a b,+          to ~ (->)) => Labelable x Variant s t a b where+    type LabelableTy Variant = LabelablePrism+    hLens' x s = hPrism x s++-- | @hLens' :: Label a -> Prism' (TIC s) a@+--+-- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@,+-- cannot have an instance of Labelable+--+-- Note: `x :: k` according to the instance head, but the instance body+-- forces the kind variable to be * later on. IE. (k ~ *)+instance (TICPrism s t a b, Label x ~ Label a,a ~ b, s ~ t,+          SameLength s t) =>+    Labelable (x :: k) TIC s t a b where+      type LabelableTy TIC = LabelablePrism+      hLens' _ = ticPrism+++-- | make a @Lens' (TIP s) a@.+--+-- 'tipyLens' provides a @Lens (TIP s) (TIP t) a b@, which tends to need+-- too many type annotations to be practical+instance LabelableTIPCxt x s t a b =>+    Labelable (x :: k) TIP s t a b where+    type LabelableTy TIP = LabelableLens+    hLens' x = hLens x++type LabelableTIPCxt x s t a b =+     (s ~ t, a ~ b, Label x ~ Label a,+      HLens x TIP s t a b)+++-- | modification of '.=.' which works with the labels from this module,+-- and those from "Data.HList.Label6". Note that this is not strictly a+-- generalization of '.=.', since it does not work with labels like+-- "Data.HList.Label3" which have the wrong kind.+l .==. v = toLabel l .=. v++infixr 4 .==.++-- | Get the Symbol out of a 'Label' or 'LabeledTo'+class ToSym label (s :: Symbol) | label -> s++instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3+    => ToSym (v1 v2 v3) x++instance ToSym (label x) x++{- | Convert a type to @Label :: Label blah@++> toLabel :: LabeledTo x _ _ -> Label (x :: Symbol)+> toLabel (hLens' lx)         = (lx :: Label x)+> toLabel :: Label x         -> Label x+> toLabel :: Proxy x         -> Label x++-}+class EnsureLabel x y | x -> y where+  toLabel :: x -> y++instance EnsureLabel (Label x) (Label (x :: k)) where+  toLabel _ = Label++instance EnsureLabel (Proxy x) (Label (x :: k)) where+  toLabel _ = Label++-- | get the Label out of a 'LabeledTo' (ie. `foobar when using HListPP).+instance ToSym (a b c) (x :: Symbol) => EnsureLabel (a b c) (Label x) where+  toLabel _ = Label+++-- | fix the `k` kind variable to 'Symbol'+toLabelSym label = toLabel label `asTypeOf` (Label :: Label (x :: Symbol))+++{- $comparisonWithhLensFunction++Note that passing around variables defined with 'hLens'' doesn't get+you exactly the same thing as calling 'hLens' at the call-site:++The following code needs to apply the @x@ for different @Functor+f =>@, so you would have to write a type signature (rank-2) to allow this+definition:++ > -- with the x defined using hLens'+ > let f x r = let+ >          a = r ^. x+ >          b = r & x .~ "6"+ >        in (a,b)++This alternative won't need a type signature++ > -- with the x defined as x = Label :: Label "x"+ > let f x r = let+ >          a = r ^. hLens x+ >          b = r & hLens x .~ "7"+ >        in (a,b)++It may work to use 'hLens'' instead of 'hLens' in the second code,+but that is a bit beside the point being made here.++The same points apply to the use of 'hPrism' over 'hLens''.++-}++{- | Sometimes it may be more convenient to operate on a record/variant+that only contains the fields of interest. 'projected' can then be used+to apply that function to a record that contains additional elements.+++>>> :set -XViewPatterns+>>> import Data.HList.RecordPuns+>>> let f [pun| (x y) |] = case x+y of z -> [pun| z |]+>>> :t f+f :: Num v =>+     Record '[Tagged "x" v, Tagged "y" v] -> Record '[Tagged "z" v]++>>> let r = (let x = 1; y = 2; z = () in [pun| x y z |])+>>> r+Record{x=1,y=2,z=()}++>>> r & sameLabels . projected %~ f+Record{x=1,y=2,z=3}+++++-}+class Projected r s t a b where+    projected :: (ty ~ LabelableTy r,+                LabeledOpticP ty p,+                LabeledOpticF ty f) => r a `p` f (r b) -> r s `p` f (r t)++-- | @Lens rs rt ra rb@+--+-- where @rs ~ Record s, rt ~ Record t, ra ~ Record a, rb ~ Record b@+instance (-- for Record s -> Record a+          H2ProjectByLabels (LabelsOf a) s a_ _s_minus_a,+          HRLabelSet a_, HRLabelSet a,+          HRearrange (LabelsOf a) a_ a,++          HLeftUnion b s bs, HRLabelSet bs,+          HRearrange (LabelsOf t) bs t, HRLabelSet t+        ) => Projected Record s t a b where+    projected f s = (\b -> hRearrange' (b .<++. s)) <$> f (hProjectByLabels' s :: Record a)++-- | @Prism (Variant s) (Variant t) (Variant a) (Variant b)@+instance (ExtendsVariant b t,+          ProjectVariant s a,+          ProjectExtendVariant s t,++          HLeftUnion b s bs, HRLabelSet bs,+          HRearrange (LabelsOf t) bs t)+      => Projected Variant s t a b where+    projected = prism extendsVariant+            (\s -> case projectVariant s of+                    Just a -> Right a+                    Nothing | Just t <- projectExtendVariant s -> Left t+                    _ -> error "Data.HList.Labelable.projected impossible"+                    -- projectExtendVariant gives Nothing when the element of+                    -- `t` that is actually stored in the variant comes+                    -- from the `b`. But in that case the projectVariant+                    -- above must have been Just+              )+++{- | @Lens' (Record s) (Record a)@++@Prism' (Variant s) (Variant a)@+-}+projected' s = isSimple projected s+++{- | Together with the instance below, this allows writing++@+'makeLabelable' "x y z"+p = x .*. y .*. z .*. 'emptyProxy'+@++Or with HListPP++@+p = `x .*. `y .*. `z .*. emptyProxy+@++instead of++> p = Proxy :: Proxy ["x","y","z"]++-}+instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy ('[] :: [*])) where+    type HExtendR (to p q) (Proxy ('[] :: [*])) = Proxy '[GetXFromLabeledTo to]+    (.*.) _ _ = Proxy++instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy (x ': xs)) where+    type HExtendR (to p q) (Proxy (x ': xs)) = Proxy (GetXFromLabeledTo to ': x ': xs)+    (.*.) _ _ = Proxy++-- | if the proxy has Data.HList.Label3."Lbl", then everything has to be+-- wrapped in Label to make the kinds match up.+instance (to ~ LabeledTo x, ToSym (to p q) x)+       => HExtend (to p q) (Proxy (Lbl n ns desc ': xs)) where+    type HExtendR (to p q) (Proxy (Lbl n ns desc ': xs))+        = Proxy (Label (GetXFromLabeledTo to) ': MapLabel (Lbl n ns desc ': xs))+    (.*.) _ _ = Proxy++type family GetXFromLabeledTo (to :: * -> * -> *) :: Symbol+type instance GetXFromLabeledTo (LabeledTo x) = x+
+ hlist/Data/HList/MakeLabels.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++{- | Description : Automate some of the ways to make labels.++-}++module Data.HList.MakeLabels (+    makeLabels,+    makeLabels3,++    -- * labels using kind 'Symbol'+    makeLabels6,+    makeLabelable,+    ) where++import Data.Typeable+import Data.HList.FakePrelude+import Data.HList.Label3+import Data.HList.Labelable++import Language.Haskell.TH+import Data.Char+import Control.Monad++make_cname, make_dname :: String -> Name+make_cname (x:xs) = mkName ("Label" ++ toUpper x : xs)+make_cname _ = error "Data.HList.MakeLabels.make_cname: empty string"++make_dname (x:xs) = mkName (toLower x : xs)+make_dname _ = error "Data.HList.MakeLabels.make_dname: empty string"++dcl :: String -> Q [Dec]+dcl n = let+    c = make_cname n+    d = make_dname n++    dd =+#if MIN_VERSION_template_haskell(2,12,0)+      dataD (return []) c [] Nothing [] [derivClause Nothing [ [t| Typeable |] ]]+#elif MIN_VERSION_template_haskell(2,11,0)+      dataD (return []) c [] Nothing [] (fmap (:[]) [t| Typeable |])+#else+      dataD (return []) c [] [] [''Typeable]+#endif++    labelSig = sigD d [t| Label $(conT c) |]++    labelDec = valD+                  (varP d)+                  (normalB [| Label |])+                  []++    showInst = instanceD+            (return [])+            [t| Show $(conT c) |]+            [valD (varP 'show)+                (normalB [| \_ -> n |])+                [] ]++ in sequence [+        labelSig,+        labelDec,++        dd,++        showInst ]+++{- |++Labels like "Data.HList.Label5".++ The following TH declaration splice should be placed at top-level, before the+ created values are used. Enable @-XTemplateHaskell@ too.++>  makeLabels ["getX","getY","draw","X"]++should expand into the following declarations++> data LabelGetX deriving Typeable+> data LabelGetY deriving Typeable+> data LabelDraw deriving Typeable+> data LabelX deriving Typeable++> getX = Label :: Label LabelGetX+> getY = Label :: Label LabelGetY+> draw = Label :: Label LabelDraw+> x    = Label :: Label LabelX++-}+makeLabels :: [String] -> Q [Dec]+makeLabels = fmap concat . mapM dcl+++-- | 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)++        sq1 = valD (varP (make_dname k))+                (normalB [| firstLabel (undefined :: $(conT (make_cname ns)))+                                       (undefined :: $(conT (make_cname k))) |])+                []++        sqs = [ valD (varP (make_dname k2))+                (normalB [| nextLabel $(varE (make_dname k1))+                                    (undefined :: $(conT (make_cname k2))) |])+                []++                | (k1,k2) <- zip (k:ks) ks ]++    in fmap concat $ sequence [ pt1, sequence (sq1 : sqs) ]+-- possibly there is a better option+makeLabels3 ns [] = fail ("makeLabels3 "++ ns ++ " []")++{- | for "Data.HList.Label6"++> makeLabels6 ["x","y"]++is a shortcut for++> x = Label :: Label "x"+> y = Label :: Label "y"++-}+makeLabels6 :: [String] -> Q [Dec]+makeLabels6 ns = fmap concat $ forM ns $ \n -> sequence+  [sigD (make_dname n) [t| Label $(litT (strTyLit n)) |],+   valD (varP (make_dname n)) (normalB [| Label |]) []]+++{- | @makeLabelable \"x y z\"@ expands out to++> x = hLens' (Label :: Label "x")+> y = hLens' (Label :: Label "y")+> z = hLens' (Label :: Label "z")++Refer to "Data.HList.Labelable" for usage.++-}+makeLabelable :: String -> Q [Dec]+makeLabelable xs = fmap concat $ mapM makeLabel1 (words xs)+    where+        -- a bit indirect, ghc-7.6 TH is a bit too eager to reject+        -- mis-matched kind variables+        makeLabel1 x = sequence+              [+                sigD (mkName x) makeSig,+                valD (varP (mkName x)) (normalB (varE 'hLens' `appE` lt))+                            []+                ]+            where lt = [| Label :: $([t| Label $l |]) |]+                  l = litT (strTyLit x)++                  makeSig = [t| forall r s t a b. (Labelable $l r s t a b) =>+                              LabeledOptic $l r s t a b+                              |]
+ hlist/Data/HList/Record.hs view
@@ -0,0 +1,1343 @@+{-# LANGUAGE CPP #-}+{- |+   The HList library++   (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Extensible records++   The three-ish models of labels that go with this module;++   * "Data.HList.Label3"++   * "Data.HList.Label5"++   * "Data.HList.Label6"++   * "Data.HList.Labelable"+++   These used to work:++   * "Data.HList.Label1"++   * "Data.HList.Label2"++   * "Data.HList.Label4"++-}++module Data.HList.Record+(+    -- ** labels used for doctests+    -- $setup++    -- * Records++    -- ** Labels+    -- $labels+    module Data.Tagged,+    (.=.),++    -- ** Record+    Record(..),+    mkRecord,+    emptyRecord,+    hEndR,+    hEndP,++    hListRecord, hListRecord',++    -- *** Getting Labels+    LabelsOf,+    labelsOf,+    asLabelsOf,++    -- *** Getting Values+    RecordValues(..),+    recordValues,+    hMapTaggedFn,++    unlabeled0,++    Unlabeled,+    unlabeled,+    Unlabeled',+    unlabeled',++    -- * Operations+    -- ** Show+    -- | A corresponding 'Show' instance exists as+    --+    -- > show x = "Record {" ++ showComponents "" x ++ "}"+    ShowComponents(..),+    ShowLabel(..),++    -- ** Extension+    -- | 'hExtend', 'hAppend'+    (.*.),++    -- ** Delete+    -- | 'hDeleteAtLabel' @label record@+    (.-.),+    HDeleteLabels(..),++    -- ** Lookup/update+    -- $lens+    HLens(hLens),++    -- ** Lookup+    HasField(..),+    HasFieldM(..),+    (.!.),++    -- ** Update+    (.@.),+    HUpdateAtLabel(hUpdateAtLabel),+    -- *** type-preserving versions+    -- | Note: these restrict the resulting record type to be the same as in+    -- input record type, which can help reduce the number of type annotations+    -- needed+    (.<.),+    HTPupdateAtLabel,+    hTPupdateAtLabel,++    -- ** Rename Label+    hRenameLabel,++    -- ** Projection++    Labels,++    -- $projection+    hProjectByLabels,+    hProjectByLabels',+    hProjectByLabels2,++    -- *** a lens for projection+    -- | see "Data.HList.Labelable".'Projected'++    -- ** Unions+    -- *** Left+    HLeftUnion(hLeftUnion),+    (.<++.),++    -- *** Symmetric+    -- $symmetricUnion+    UnionSymRec(unionSR),+++    -- ** Reorder Labels+    hRearrange,+    hRearrange',++    -- *** isos using hRearrange+    Rearranged(rearranged), rearranged',+++    -- ** Apply a function to all values+    hMapR, HMapR(..),++    -- ** cast labels+    Relabeled(relabeled),+    relabeled',++    -- * Hints for type errors+    DuplicatedLabel,+    ExtraField,+    FieldNotFound,++    -- * Unclassified++    -- | Probably internals, that may not be useful+#if __GLASGOW_HASKELL__ != 706+    zipTagged,+#endif+    HasField'(..),+    DemoteMaybe,+    HasFieldM1(..),+    H2ProjectByLabels(h2projectByLabels),+    H2ProjectByLabels'(h2projectByLabels'),+    HLabelSet,+    HLabelSet',+    HRLabelSet,+    HAllTaggedLV,+    HRearrange(hRearrange2),+    HRearrange3(hRearrange3),+    HRearrange4(hRearrange4),+    UnionSymRec'(..),+    HFindLabel,+    labelLVPair,+    newLVPair,+    UnLabel,+    HMemberLabel,+    TaggedFn(..),+    ReadComponent,+    HMapTaggedFn,+    HLensCxt,++    -- ** zip+    -- | use the more general 'HZip' class instead+    HZipRecord(..),+    -- *** alternative implementation+    hZipRecord2, hUnzipRecord2+) where+++import Data.HList.FakePrelude+import Data.HList.HListPrelude+import Data.HList.HList++import Data.HList.Label3 (MapLabel)++import Data.Tagged+import Control.Monad++import Text.ParserCombinators.ReadP++import LensDefs++import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif+-- imports for doctest/examples+import Data.HList.Label6 ()+import Data.HList.TypeEqO ()++{- $setup++>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let z = Label :: Label "z"++-}++-- --------------------------------------------------------------------------++-- $labels Record types as label-value pairs, where label is purely phantom.+-- Thus the run-time representation of a field is the same as that of+-- its value, and the record, at run-time, is indistinguishable from+-- the HList of field values. At run-time, all information about the+-- labels is erased.+--+-- The type from "Data.Tagged" is used.++-- | Label accessor+labelLVPair :: Tagged l v -> Label l+labelLVPair _ = Label++newLVPair :: Label l -> v -> Tagged l v+newLVPair _ = Tagged++++infixr 4 .=.+{-|++  Create a value with the given label. Analagous to a data+  constructor such as 'Just', 'Left', or 'Right'. Higher fixity+  than record-modification operations like ('.*.'), ('.-.'), etc. to+  support expression like the below w/o parentheses:++  >>> x .=. "v1" .*. y .=. '2' .*. emptyRecord+  Record{x="v1",y='2'}++-}+(.=.) :: Label l -> v -> Tagged l v+l .=. v = newLVPair l v+++newtype Record (r :: [*]) = Record (HList r)++deriving instance Semigroup (HList r) => Semigroup (Record r)+deriving instance Monoid (HList r) => Monoid (Record r)+deriving instance (Eq (HList r)) => Eq (Record r)+deriving instance (Ord (HList r)) => Ord (Record r)+deriving instance (Ix (HList r)) => Ix (Record r)+deriving instance (Bounded (HList r)) => Bounded (Record r)+++-- | Build a record+mkRecord :: HRLabelSet r => HList r -> Record r+mkRecord = Record++-- | @HRLabelSet t => Iso (HList s) (HList t) (Record s) (Record t)@+hListRecord x = isoNewtype mkRecord (\(Record r) -> r) x++-- | @Iso' (HList s) (Record s)@+hListRecord' x = isSimple hListRecord x++-- | Build an empty record+emptyRecord :: Record '[]+emptyRecord = mkRecord HNil++-- | @Iso (Record s) (Record t) (HList a) (HList b)@+--+-- @view unlabeled == 'recordValues'@+unlabeled0 x = sameLabels (iso recordValues hMapTaggedFn x)+++unlabeled :: (Unlabeled x y, Profunctor p, Functor f) =>+    (HList (RecordValuesR x) `p` f (HList (RecordValuesR y))) ->+    (Record x `p` f (Record y))+unlabeled x = sameLength (unlabeled0 (sameLength x))++type Unlabeled x y =+      (HMapCxt HList TaggedFn (RecordValuesR y) y,+       RecordValues x, RecordValues y,+       SameLength (RecordValuesR x) (RecordValuesR y),+       SameLength x y, SameLabels x y,+       HAllTaggedLV x, HAllTaggedLV y)+type Unlabeled' x = Unlabeled x x++++-- | @Unlabeled' x => Iso' (Record x) (HList (RecordValuesR x))@+unlabeled' :: (Unlabeled' x, Profunctor p, Functor f) =>+    (HList (RecordValuesR x) `p` f (HList (RecordValuesR x))) ->+    (Record x `p` f (Record x))+unlabeled' = unlabeled++{- | @Iso (Record s) (Record t) (Record a) (Record b)@, such that+@relabeled = unlabeled . from unlabeled@++in other words, pretend a record has different labels, but the same values.++-}+class Relabeled r where+  relabeled :: forall p f s t a b.+      (HMapTaggedFn (RecordValuesR s) a,+       HMapTaggedFn (RecordValuesR b) t,+       SameLengths '[s,a,t,b],+       RecordValuesR t ~ RecordValuesR b,+       RecordValuesR s ~ RecordValuesR a,+       RecordValues b, RecordValues s,+       Profunctor p,+       Functor f+       ) => r a `p` f (r b) -> r s `p` f (r t)++instance Relabeled Record where+  relabeled = iso+    (\ s -> hMapTaggedFn (recordValues s))+    (\ b -> hMapTaggedFn (recordValues b))+    -- isoNewtype should be safe here, but there are no guarantees+    -- http://stackoverflow.com/questions/24222552++-- | @Iso' (Record s) (Record a)@+--+-- such that @RecordValuesR s ~ RecordValuesR a@+relabeled' x = isSimple relabeled x++data TaggedFn = TaggedFn+instance (tx ~ Tagged t x) => ApplyAB TaggedFn x tx where+    applyAB _ = Tagged++type HMapTaggedFn l r =+    (HMapCxt HList TaggedFn l r,+     RecordValuesR r ~ l,+     RecordValues r)++-- | \"inverse\" to 'recordValues'+hMapTaggedFn :: HMapTaggedFn a b => HList a -> Record b+hMapTaggedFn = Record . hMap TaggedFn++-- | Property of a proper label set for a record: no duplication of labels,+-- and every element of the list is @Tagged label value@++data DuplicatedLabel l++class (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*])+instance (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*])+++++{- | Relation between HLabelSet and HRLabelSet++> instance HLabelSet (LabelsOf ps) => HRLabelSet ps++see also 'HSet'+-}++class HLabelSet ls+instance HLabelSet '[]+instance HLabelSet '[x]+instance ( HEqK l1 l2 leq+         , HLabelSet' l1 l2 leq r+         ) => HLabelSet (l1 ': l2 ': r)++class HLabelSet' l1 l2 (leq::Bool) r+instance ( HLabelSet (l2 ': r)+         , HLabelSet (l1 ': r)+         ) => HLabelSet' l1 l2 False r+instance ( Fail (DuplicatedLabel l1) ) => HLabelSet' l1 l2 True r++-- | Construct the (phantom) list of labels of a record,+-- or list of Label.+type family LabelsOf (ls :: [*]) :: [*]+type instance LabelsOf '[] = '[]+type instance LabelsOf (Label l ': r)  = Label l ': LabelsOf r+type instance LabelsOf (Tagged l v ': r) = Label l ': LabelsOf r++labelsOf :: hlistOrRecord l -> Proxy (LabelsOf l)+labelsOf _ = Proxy++++-- | remove the Label type constructor. The @proxy@ argument is+-- supplied to make it easier to fix the kind variable @k@.+type family UnLabel (proxy :: k) (ls :: [*]) :: [k]+type instance UnLabel proxy (Label x ': xs) = x ': UnLabel proxy xs+type instance UnLabel proxy '[] = '[]++-- | A version of 'HFind' where the @ls@ type variable is a list of+-- 'Tagged' or 'Label'. This is a bit indirect, and ideally LabelsOf+-- could have kind [*] -> [k].+type HFindLabel (l :: k) (ls :: [*]) (n :: HNat) = HFind l (UnLabel l (LabelsOf ls)) n++-- | Construct the HList of values of the record.+class SameLength r (RecordValuesR r)+      => RecordValues (r :: [*]) where+  type RecordValuesR r :: [*]+  recordValues' :: HList r -> HList (RecordValuesR r)++instance RecordValues '[] where+  type RecordValuesR '[] = '[]+  recordValues' _ = HNil+instance (SameLength' r (RecordValuesR r),+          SameLength' (RecordValuesR r) r, RecordValues r) => RecordValues (Tagged l v ': r) where+   type RecordValuesR (Tagged l v ': r) = v ': RecordValuesR r+   recordValues' (HCons (Tagged v) r) = HCons v (recordValues' r)++recordValues :: RecordValues r => Record r -> HList (RecordValuesR r)+recordValues (Record r) = recordValues' r++{- shorter, but worse in terms needing annotations to allow ambiguous types+- but better in terms of inference+recordValues :: RecordValues r rv => Record r -> HList rv+recordValues (Record r) = hMap HUntag r++type RecordValues r rv = HMapCxt HUntag r rv+-}++-- --------------------------------------------------------------------------++-- 'Show' instance to appeal to normal records++instance ShowComponents r => Show (Record r) where+  show (Record r) =  "Record{"+                  ++ showComponents "" r+                  ++ "}"++class ShowComponents l where+  showComponents :: String -> HList l -> String++instance ShowComponents '[] where+  showComponents _ _ = ""++instance ( ShowLabel l+         , Show v+         , ShowComponents r+         )+      =>   ShowComponents (Tagged l v ': r) where+  showComponents comma (HCons f@(Tagged v) r)+     =  comma+     ++ showLabel ((labelLVPair f) :: Label l)+     ++ "="+     ++ show v+     ++ showComponents "," r+++-- --------------------------------------------------------------------------++-- 'Read' instance to appeal to normal records+++data ReadComponent = ReadComponent Bool -- ^ include comma?++instance (Read v, ShowLabel l,+          x ~ Tagged l v,+          ReadP x ~ y) =>+  ApplyAB ReadComponent (Proxy x) y where+    applyAB (ReadComponent comma) _ = do+      when comma (() <$ string ",")+      _ <- string (showLabel (Label :: Label l))+      _ <- string "="+      v <- readS_to_P reads+      return (Tagged v)+++instance (HMapCxt HList ReadComponent (AddProxy rs) bs,+          ApplyAB ReadComponent (Proxy r) readP_r,+          HProxies rs,+          HSequence ReadP (readP_r ': bs) (r ': rs),+          readP_r ~ ReadP (Tagged l v),++          -- ghc-8.0.2 needs these. The above constraints+          -- should imply them+          r ~ Tagged l v,+          ShowLabel l,+          Read v,+          HSequence ReadP bs rs+          ) => Read (Record (r ': rs)) where+    readsPrec _ = readP_to_S $ do+        _ <- string "Record{"+        content <- hSequence parsers+        _ <- string "}"+        return (Record content)++      where+        rs :: HList (AddProxy rs)+        rs = hProxies++        readP_r :: readP_r+        readP_r = applyAB+                      (ReadComponent False)+                      (Proxy :: Proxy r)++        parsers = readP_r `HCons` (hMap (ReadComponent True) rs :: HList bs)++++++-- --------------------------------------------------------------------------++-- Extension++instance HRLabelSet (t ': r)+    => HExtend t (Record r) where+  type HExtendR t (Record r) = Record (t ': r)+  f .*. (Record r) = mkRecord (HCons f r)+++-- * For records++{-|++  [@(.*.)@]+           Add a field to a record. Analagous to (++) for+           lists.++  > record .*. field1+  >        .*. field2++-}++-- --------------------------------------------------------------------------++-- Concatenation++instance (HRLabelSet (HAppendListR r1 r2), HAppend (HList r1) (HList r2))+    => HAppend (Record r1) (Record r2) where+  hAppend (Record r) (Record r') = mkRecord (hAppend r r')++type instance HAppendR (Record r1) (Record r2) = Record (HAppendListR r1 r2)+-- --------------------------------------------------------------------------++-- Lookup+--+-- |+-- This is a baseline implementation.+-- We use a helper class, HasField, to abstract from the implementation.++-- | Because 'hLookupByLabel' is so frequent and important, we implement+-- it separately, more efficiently. The algorithm is familiar assq, only+-- the comparison operation is done at compile-time+class HasField (l::k) r v | l r -> v where+    hLookupByLabel:: Label l -> r -> v++{- alternative "straightforward" implementation+instance ( LabelsOf r ~ ls+         , HFind l ls n+         , HLookupByHNat n r+         , HLookupByHNatR n r ~ LVPair l v+         ) => HasField l (Record r) v+  where+    hLookupByLabel l (Record r) = v+      where+        (LVPair v) = hLookupByHNat (proxy :: Proxy n) r+-}++{- | a version of 'HasField' / 'hLookupByLabel' / '.!.' that+returns a default value when the label is not in the record:++>>> let r = x .=. "the x value" .*. emptyRecord++>>> hLookupByLabelM y r ()+()++>>> hLookupByLabelM x r ()+"the x value"++++-}+class HasFieldM (l :: k) r (v :: Maybe *) | l r -> v where+    hLookupByLabelM :: Label l+          -> r -- ^ Record (or Variant,TIP,TIC)+          -> t -- ^ default value+          -> DemoteMaybe t v++type family DemoteMaybe (d :: *) (v :: Maybe *) :: *+type instance DemoteMaybe d (Just a) = a+type instance DemoteMaybe d Nothing = d++class HasFieldM1 (b :: Maybe [*]) (l :: k) r v | b l r -> v where+    hLookupByLabelM1 :: Proxy b -> Label l -> r -> t -> DemoteMaybe t v++instance (HMemberM (Label l) (LabelsOf xs) b,+          HasFieldM1 b l (r xs) v)  => HasFieldM l (r xs) v where+    hLookupByLabelM = hLookupByLabelM1 (Proxy :: Proxy b)++instance HasFieldM1 Nothing l r Nothing where+    hLookupByLabelM1 _ _ _ t = t++instance HasField l r v => HasFieldM1 (Just b) l r (Just v) where+    hLookupByLabelM1 _ l r _t = hLookupByLabel l r++++instance (HEqK l l1 b, HasField' b l (Tagged l1 v1 ': r) v)+    => HasField l (Record (Tagged l1 v1 ': r)) v where+    hLookupByLabel l (Record r) =+             hLookupByLabel' (Proxy::Proxy b) l r++-- | XXX+instance (t ~ Any, Fail (FieldNotFound l ())) => HasField l (Record '[]) t where+    hLookupByLabel _ _ = error "Data.HList.Record.HasField: Fail instances should not exist"+++class HasField' (b::Bool) (l :: k) (r::[*]) v | b l r -> v where+    hLookupByLabel':: Proxy b -> Label l -> HList r -> v++instance HasField' True l (Tagged l v ': r) v where+    hLookupByLabel' _ _ (HCons (Tagged v) _) = v+instance HasField l (Record r) v => HasField' False l (fld ': r) v where+    hLookupByLabel' _ l (HCons _ r) = hLookupByLabel l (Record r)++++infixr 9 .!.+{- |+  Lookup a value in a record by its label. Analagous to (!!), the+  list indexing operation. Highest fixity, like ('!!').++  >>> :{+  let record1 = x .=. 3 .*.+                y .=. 'y' .*.+                emptyRecord+  :}+++  >>> record1 .!. x+  3++  >>> record1 .!. y+  'y'+++  >>> :{+  let r2 = y .=. record1 .!. x .*.+           z .=. record1 .!. y .*.+           emptyRecord+  :}++  >>> r2+  Record{y=3,z='y'}++  Note that labels made following "Data.HList.Labelable" allow+  using "Control.Lens.^." instead.+-}+++(.!.) :: (HasField l r v) => r -> Label l -> v+r .!. l =  hLookupByLabel l r++-- --------------------------------------------------------------------------++-- Delete++instance (H2ProjectByLabels '[Label l] v t1 v')+      => HDeleteAtLabel Record l v v' where+  hDeleteAtLabel _ (Record r) =+    Record $ snd $ h2projectByLabels (Proxy::Proxy '[Label l]) r++infixl 2 .-.+{-|+  Remove a field from a record. At the same+  level as other record modification options ('.*.'). Analagous+  to (@\\\\@) in lists.++  > record1 .-. label1++  > label1 .=. value1 .*.+  > label2 .=. value2 .-.+  > label2 .*.+  > emptyRecord++  > label1 .=. value1 .-.+  > label1 .*.+  > label2 .=. value2 .*.+  > emptyRecord++  > record1 .*. label1 .=. record2 .!. label1+  >         .*. label2 .=. record2 .!. label2+  >         .-. label1++-}+(.-.) :: (HDeleteAtLabel r l xs xs') =>+    r xs -> Label l -> r xs'+r .-. l =  hDeleteAtLabel l r+++-- --------------------------------------------------------------------------++-- Update++-- | 'hUpdateAtLabel' @label value record@++class+    HUpdateAtLabel record (l :: k) (v :: *) (r :: [*]) (r' :: [*])+          | l v r -> r', l r' -> v where+    hUpdateAtLabel :: SameLength r r' => Label l -> v -> record r -> record r'++instance (HUpdateAtLabel2 l v r r',+        HasField l (Record r') v) =>+        HUpdateAtLabel Record l v r r' where+    hUpdateAtLabel = hUpdateAtLabel2++{- alternative impl which reports a Fail constraint that is too long (the+one from HUpdateAtHNat) on ghc 7.10 RC1++instance (HasField l (Record r') v,+          HFindLabel l r n,+          HUpdateAtHNat n (Tagged l v) r,+          HUpdateAtHNatR n (Tagged l v) r ~ r',+          SameLength r r') =>+  HUpdateAtLabel Record l v r r' where+  hUpdateAtLabel l v (Record r) =+    Record (hUpdateAtHNat (Proxy::Proxy n) (newLVPair l v) r)+-}++class HUpdateAtLabel2 (l :: k) (v :: *) (r :: [*]) (r' :: [*])+        | l r v -> r' where+    hUpdateAtLabel2 :: Label l -> v -> Record r -> Record r'++class HUpdateAtLabel1 (b :: Bool) (l :: k) (v :: *) (r :: [*]) (r' :: [*])+        | b l v r -> r' where+    hUpdateAtLabel1 :: Proxy b -> Label l -> v -> Record r -> Record r'++instance HUpdateAtLabel1 True l v (Tagged l e ': xs) (Tagged l v ': xs) where+    hUpdateAtLabel1 _b _l v (Record (e `HCons` xs)) = Record (e{ unTagged = v } `HCons` xs)++instance HUpdateAtLabel2 l v xs xs' => HUpdateAtLabel1 False l v (x ': xs) (x ': xs') where+    hUpdateAtLabel1 _b l v (Record (x `HCons` xs)) = case hUpdateAtLabel2 l v (Record xs) of+        Record xs' -> Record (x `HCons` xs')++instance (HEqK l l' b, HUpdateAtLabel1 b l v (Tagged l' e ': xs) xs')+    => HUpdateAtLabel2 l v (Tagged l' e ': xs) xs' where+    hUpdateAtLabel2 = hUpdateAtLabel1 (Proxy :: Proxy b)++-- | XXX+instance Fail (FieldNotFound l ()) => HUpdateAtLabel2 l v '[] '[] where+    hUpdateAtLabel2 _ _ r = r+++infixr 2 .@.+{-|++  Update a field with a particular value.+  Same fixity as (.*.) so that extensions and updates can be chained.+  There is no real list analogue, since there is no Prelude defined+  update.++  > label1 .=. value1 .@. record1++-}+f@(Tagged v) .@. r  =  hUpdateAtLabel (labelLVPair f) v r+++-- --------------------------------------------------------------------------+-- Projection++-- $projection+-- It is also an important operation: the basis of many+-- deconstructors -- so we try to implement it efficiently.+++-- | @hProjectByLabels ls r@ returns @r@ with only the labels in @ls@ remaining+hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) =>+        proxy ls -> Record t -> Record a+hProjectByLabels ls (Record r) = mkRecord (fst $ h2projectByLabels ls r)++-- | See 'H2ProjectByLabels'+hProjectByLabels2 ::+    (H2ProjectByLabels ls t t1 t2, HRLabelSet t1, HRLabelSet t2) =>+    Proxy ls -> Record t -> (Record t1, Record t2)+hProjectByLabels2 ls (Record r) = (mkRecord rin, mkRecord rout)+   where (rin,rout) = h2projectByLabels ls r++-- need to rearrange because the ordering in the result is determined by+-- the ordering in the original record, not the ordering in the proxy. In+-- other words,+--+-- > hProjectByLabels (Proxy :: Proxy ["x","y"]) r == hProjectByLabels (Proxy :: Proxy ["y","x"]) r+hProjectByLabels' r =+    let r' = hRearrange' (hProjectByLabels (labelsOf r') r)+    in r'++++{- | A helper to make the Proxy needed by hProjectByLabels,+and similar functions which accept a list of kind [*].++For example:++@(rin,rout) = 'hProjectByLabels2' (Proxy :: Labels ["x","y"]) r@++behaves like++> rin = r .!. (Label :: Label "x") .*.+>       r .!. (Label :: Label "y") .*.+>       emptyRecord+>+> rout = r .-. (Label :: Label "x") .-. (Label :: Label "y")++-}+type family Labels (xs :: [k]) :: *+type instance Labels xs = Proxy (Labels1 xs)++type family Labels1 (xs :: [k]) :: [*]+type instance Labels1 '[] = '[]+type instance Labels1 (x ': xs) = Label x ': Labels1 xs++-- | /Invariant/:+--+--  > r === rin `disjoint-union` rout+--  > labels rin === ls+--  >     where (rin,rout) = hProjectByLabels ls r+class H2ProjectByLabels (ls::[*]) r rin rout | ls r -> rin rout where+    h2projectByLabels :: proxy ls -> HList r -> (HList rin,HList rout)++instance H2ProjectByLabels '[] r '[] r where+    h2projectByLabels _ r = (HNil,r)++instance H2ProjectByLabels (l ': ls) '[] '[] '[] where+    h2projectByLabels _ _ = (HNil,HNil)++instance (HMemberM (Label l1) ((l :: *) ': ls) (b :: Maybe [*]),+          H2ProjectByLabels' b (l ': ls) (Tagged l1 v1 ': r1) rin rout)+    => H2ProjectByLabels (l ': ls) (Tagged l1 v1 ': r1) rin rout where+    h2projectByLabels = h2projectByLabels' (Proxy::Proxy b)++class H2ProjectByLabels' (b::Maybe [*]) (ls::[*]) r rin rout+                         | b ls r -> rin rout where+    h2projectByLabels' :: Proxy b -> proxy ls ->+                                     HList r -> (HList rin,HList rout)++instance H2ProjectByLabels ls1 r rin rout =>+    H2ProjectByLabels' ('Just ls1) ls (f ': r) (f ': rin) rout where+    h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout)+        where (rin,rout) = h2projectByLabels (Proxy::Proxy ls1) r++-- | if ls above has labels not in the record,+-- we get labels (rin `isSubsetOf` ls).+instance H2ProjectByLabels ls r rin rout =>+    H2ProjectByLabels' 'Nothing ls (f ': r) rin (f ': rout) where+    h2projectByLabels' _ ls (HCons x r) = (rin, HCons x rout)+        where (rin,rout) = h2projectByLabels ls r++-- --------------------------------------------------------------------------+{- | Rename the label of record++>>> hRenameLabel x y (x .=. () .*. emptyRecord)+Record{y=()}++-}+hRenameLabel l l' r = r''+ where+  v   = hLookupByLabel l r+  r'  = hDeleteAtLabel l r+  r'' = newLVPair l' v .*. r'+++-- --------------------------------------------------------------------------++type HTPupdateAtLabel record l v r = (HUpdateAtLabel record l v r r, SameLength' r r)++-- | A variation on 'hUpdateAtLabel': type-preserving update.+hTPupdateAtLabel :: HTPupdateAtLabel record l v r => Label l -> v -> record r -> record r+hTPupdateAtLabel l v r = hUpdateAtLabel l v r++{- ^++We could also say:++> hTPupdateAtLabel l v r = hUpdateAtLabel l v r `asTypeOf` r++Then we were taking a dependency on Haskell's type equivalence.+This would also constrain the actual implementation of hUpdateAtLabel.++-}++infixr 2 .<.+{-|+  The same as '.@.', except type preserving. It has the same fixity as (.\@.).++-}+f@(Tagged v) .<. r = hTPupdateAtLabel (labelLVPair f) v r++-- --------------------------------------------------------------------------+-- | Subtyping for records++instance H2ProjectByLabels (LabelsOf r2) r1 r2 rout+    => SubType (Record r1) (Record r2)+++type HMemberLabel l r b = HMember l (UnLabel l (LabelsOf r)) b++-- --------------------------------------------------------------------------++-- Left Union++class HDeleteLabels ks r r' | ks r -> r'+ where hDeleteLabels :: proxy (ks :: [*]) -- ^ as provided by labelsOf+          -> Record r -> Record r'++instance (HMember (Label l) ks b,+          HCond b (Record r2) (Record (Tagged l v ': r2)) (Record r3),+          HDeleteLabels ks r1 r2) =>+    HDeleteLabels ks (Tagged l v ': r1) r3 where+      hDeleteLabels ks (Record (HCons lv r1)) =+          case hDeleteLabels ks (Record r1) of+             Record r2 -> hCond (Proxy :: Proxy b)+                  (Record r2)+                  (Record (HCons lv r2))+instance HDeleteLabels ks '[] '[] where+    hDeleteLabels _ _ = emptyRecord+++class  HLeftUnion r r' r'' | r r' -> r''+ where hLeftUnion :: Record r -> Record r' -> Record r''++instance (HDeleteLabels (LabelsOf l) r r',+         HAppend (Record l) (Record r'),+         HAppendR (Record l) (Record r') ~ (Record lr)) => HLeftUnion l r lr+ where  hLeftUnion l r = l `hAppend` hDeleteLabels (labelsOf l) r+++infixl 1 .<++.+{-|+  Similar to list append, so give this slightly lower fixity than+  (.*.), so we can write:++   > field1 .=. value .*. record1 .<++. record2++-}+(.<++.) ::  (HLeftUnion r r' r'') => Record r -> Record r' -> Record r''+r .<++. r' = hLeftUnion r r'+++-- --------------------------------------------------------------------------+-- $symmetricUnion+-- Compute the symmetric union of two records r1 and r2 and+-- return the pair of records injected into the union (ru1, ru2).+--+-- To be more precise, we compute the symmetric union /type/ @ru@+-- of two record /types/ @r1@ and @r2@. The emphasis on types is important.+--+-- The two records (ru1,ru2) in the result of 'unionSR' have the same+-- type ru, but they are generally different values.+-- Here the simple example: suppose+--+-- >  r1 = (Label .=. True)  .*. emptyRecord+-- >  r2 = (Label .=. False) .*. emptyRecord+--+-- Then 'unionSR' r1 r2 will return (r1,r2). Both components of the result+-- are different records of the same type.+--+--+-- To project from the union ru, use 'hProjectByLabels'.+-- It is possible to project from the union obtaining a record+-- that was not used at all when creating the union.+--+-- We do assure however that if @unionSR r1 r2@ gave @(r1u,r2u)@,+-- then projecting r1u onto the type of r1 gives the /value/ identical+-- to r1. Ditto for r2.++class UnionSymRec r1 r2 ru | r1 r2 -> ru where+    unionSR :: Record r1 -> Record r2 -> (Record ru, Record ru)++instance (r1 ~ r1') => UnionSymRec r1 '[] r1' where+    unionSR r1 _ = (r1, r1)++instance ( HMemberLabel l r1 b+         , UnionSymRec' b r1 (Tagged l v) r2' ru+         )+    => UnionSymRec r1 (Tagged l v ': r2') ru+    where+    unionSR r1 (Record (HCons f r2')) =+        unionSR' (Proxy::Proxy b) r1 f (Record r2')++class UnionSymRec' (b :: Bool) r1 f2 r2' ru | b r1 f2 r2' -> ru where+    unionSR' :: Proxy b -> Record r1 -> f2 -> Record r2'  -> (Record ru, Record ru)++++-- | Field f2 is already in r1, so it will be in the union of r1+-- with the rest of r2.+--+-- To inject (HCons f2 r2) in that union, we should replace the+-- field f2+instance (UnionSymRec r1 r2' ru,+          HTPupdateAtLabel Record l2 v2 ru,+          f2 ~ Tagged l2 v2)+    => UnionSymRec' True r1 f2 r2' ru where+    unionSR' _ r1 (Tagged v2) r2' =+       case unionSR r1 r2'+        of (ul,ur) -> (ul, hTPupdateAtLabel (Label :: Label l2) v2 ur)++++instance (UnionSymRec r1 r2' ru,+          HExtend f2 (Record ru),+          Record f2ru ~ HExtendR f2 (Record ru)+        )+    => UnionSymRec' False r1 f2 r2' f2ru where+    unionSR' _ r1 f2 r2' = (ul', ur')+       where (ul,ur) = unionSR r1 r2'+             ul' = f2 .*. ul+             ur' = f2 .*. ur++-- --------------------------------------------------------------------------+-- | Rearranges a record by labels. Returns the record r, rearranged such that+-- the labels are in the order given by ls. (LabelsOf r) must be a+-- permutation of ls.+hRearrange :: (HLabelSet ls, HRearrange ls r r') => Proxy ls -> Record r -> Record r'+hRearrange ls (Record r) = Record (hRearrange2 ls r)++{- | 'hRearrange'' is 'hRearrange' where ordering specified by the Proxy+argument is determined by the result type.++With built-in haskell records, these @e1@ and @e2@ have the same type:++> data R = R { x, y :: Int }+> e1 = R{ x = 1, y = 2}+> e2 = R{ y = 2, x = 1}++'hRearrange'' can be used to allow either ordering to be accepted:++> h1, h2 :: Record [ Tagged "x" Int, Tagged "y" Int ]+> h1 = hRearrange' $+>     x .=. 1 .*.+>     y .=. 2 .*.+>     emptyRecord+>+> h2 = hRearrange' $+>     y .=. 2 .*.+>     x .=. 1 .*.+>     emptyRecord++-}+hRearrange' r =+    let r' = hRearrange (labelsOf r') r+    in r'+++class Rearranged r s t a b where+    -- @Iso (r s) (r t) (r a) (r b)@+    rearranged :: (Profunctor p, Functor f) => r a `p` f (r b) -> r s `p` f (r t)+++{- | @Iso (Record s) (Record t) (Record a) (Record b)@++where @s@ is a permutation of @a@, @b@ is a permutation of @t@.+In practice 'sameLabels' and 'sameLength' are likely needed on both+sides of @rearranged@, to avoid ambiguous types.++An alternative implementation:++> rearranged x = iso hRearrange' hRearrange' x++-}+instance (la ~ LabelsOf a, lt ~ LabelsOf t,+          HRearrange la s a,+          HRearrange lt b t,+          HLabelSet la,+          HLabelSet lt)+  => Rearranged Record s t a b where+    rearranged = iso (hRearrange (Proxy :: Proxy la))+                     (hRearrange (Proxy :: Proxy lt))++{- | @Iso' (r s) (r a)@++where @s@ is a permutation of @a@ -}+rearranged' x = isSimple rearranged x++-- | Helper class for 'hRearrange'+class (HRearrange3 ls r r', LabelsOf r' ~ ls,+       SameLength ls r, SameLength r r')+      => HRearrange (ls :: [*]) r r' | ls r -> r', r' -> ls where+    hRearrange2 :: proxy ls -> HList r -> HList r'+++instance (HRearrange3 ls r r', LabelsOf r' ~ ls,+        SameLength ls r, SameLength r r') => HRearrange ls r r' where+    hRearrange2 = hRearrange3++-- | same as HRearrange, except no backwards FD+class HRearrange3 (ls :: [*]) r r' | ls r -> r' where+    hRearrange3 :: proxy ls -> HList r -> HList r'++instance HRearrange3 '[] '[] '[] where+   hRearrange3 _ _ = HNil++instance (H2ProjectByLabels '[l] r rin rout,+          HRearrange4 l ls rin rout r',+          l ~ Label ll) =>+        HRearrange3 (l ': ls) r r' where+   hRearrange3 _ r = hRearrange4 (Proxy :: Proxy l) (Proxy :: Proxy ls) rin rout+      where (rin, rout) = h2projectByLabels (Proxy :: Proxy '[l]) r+++-- | Helper class 2 for 'hRearrange'+class HRearrange4 (l :: *) (ls :: [*]) rin rout r' | l ls rin rout -> r' where+    hRearrange4 :: proxy l -> Proxy ls -> HList rin -> HList rout -> HList r'++instance (HRearrange3 ls rout r',+         r'' ~ (Tagged l v ': r'),+         ll ~ Label l) =>+        HRearrange4 ll ls '[Tagged l v] rout r'' where+   hRearrange4 _ ls (HCons lv@(Tagged v) _HNil) rout+        = HCons (Tagged v `asTypeOf` lv) (hRearrange3 ls rout)++-- | For improved error messages. XXX FieldNotFound+instance Fail (FieldNotFound l ()) =>+        HRearrange4 l ls '[] rout '[] where+   hRearrange4 _ _ _ _ = error "Fail has no instances"++-- | For improved error messages+instance Fail (ExtraField l) =>+          HRearrange3 '[] (Tagged l v ': a) '[] where+   hRearrange3 _ _ = error "Fail has no instances"+++-- --------------------------------------------------------------------------+-- $lens+-- Lens-based setters/getters are popular. hLens packages up+-- 'hUpdateAtLabel' and 'hLookupByLabel'.+--+-- Refer to @examples/lens.hs@ and @examples/labelable.hs@ for examples.++-- | constraints needed to implement 'HLens'+type HLensCxt x r s t a b =+    (HasField x (r s) a,+     HUpdateAtLabel r x b s t,+     HasField x (r t) b,+     HUpdateAtLabel r x a t s,+     SameLength s t,+     SameLabels s t)++class HLensCxt x r s t a b => HLens x r s t a b+        | x s b -> t, x t a -> s, -- need to repeat fundeps implied by HLensCxt+          x s -> a, x t -> b where+    -- | @hLens :: Label x -> Lens (r s) (r t) a b@+    hLens :: Label x -> (forall f. Functor f => (a -> f b) -> (r s -> f (r t)))++instance HLensCxt r x s t a b => HLens r x s t a b where+  hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab))+++{- | map over the values of a record. This is a shortcut for++  > \ f (Record a) -> Record (hMap (HFmap f) a)++[@Example@]++suppose we have a function that should be applied to every element+of a record:++>>> let circSucc_ x | x == maxBound = minBound | otherwise = succ x++>>> :t circSucc_+circSucc_ :: (Bounded a, Enum a, Eq a) => a -> a++Use a shortcut ('Fun') to create a value that has an appropriate 'ApplyAB' instance:++>>> let circSucc = Fun circSucc_ :: Fun '[Eq,Enum,Bounded] '()++Confirm that we got Fun right:++>>> :t applyAB circSucc+applyAB circSucc :: (Bounded b, Enum b, Eq b) => b -> b++>>> applyAB circSucc True+False++define the actual record:++>>> let r = x .=. 'a' .*. y .=. False .*. emptyRecord+>>> r+Record{x='a',y=False}++>>> hMapR circSucc r+Record{x='b',y=True}++-}+hMapR f r = applyAB (HMapR f) r++newtype HMapR f = HMapR f++instance (HMapCxt Record f x y, rx ~ Record x, ry ~ Record y)+      => ApplyAB (HMapR f) rx ry where+        applyAB (HMapR f) = hMapAux f++instance HMapAux HList (HFmap f) x y =>+    HMapAux Record f x y where+      hMapAux f (Record x) = Record (hMapAux (HFmap f) x)++++-- --------------------------------------------------------------------------+-- | This instance allows creating a Record with+--+-- @hBuild 3 'a' :: Record '[Tagged "x" Int, Tagged "y" Char]@+instance (HReverse l lRev,+         HMapTaggedFn lRev l') => HBuild' l (Record l') where+  hBuild' l = hMapTaggedFn (hReverse l)++-- | serves the same purpose as 'hEnd'+hEndR :: Record a -> Record a+hEndR = id+++-- | see 'hEndP'+instance (HRevAppR l '[] ~ lRev,+          HExtendRs lRev (Proxy ('[] :: [*])) ~ Proxy l1,+          l' ~ l1) => HBuild' l (Proxy l') where+  hBuild' _ = Proxy++{- | @'hEndP' $ 'hBuild' label1 label2@++is one way to make a Proxy of labels (for use with 'asLabelsOf'+for example). Another way is++@label1 .*. label2 .*. 'emptyProxy'@++-}+hEndP :: Proxy (xs :: [k]) -> Proxy xs+hEndP = id++type family HExtendRs (ls :: [*]) (z :: k) :: k+type instance HExtendRs (l ': ls) z = HExtendR l (HExtendRs ls z)+type instance HExtendRs '[] z = z++-- --------------------------------------------------------------------------++{- |++>>> let x :: Record '[Tagged "x" Int]; x = undefined+>>> let y :: Record '[Tagged "x" Char]; y = undefined+>>> :t hZip x y+hZip x y :: Record '[Tagged "x" (Int, Char)]++-}+instance (HZipRecord x y xy, SameLengths [x,y,xy])+      => HZip Record x y xy where+    hZip = hZipRecord++instance (HZipRecord x y xy, SameLengths [x,y,xy])+      => HUnzip Record x y xy where+    hUnzip = hUnzipRecord+++#if __GLASGOW_HASKELL__ != 706+{- | Missing from ghc-7.6, because HZip Proxy instances interfere with HZip+HList instances.++a variation on 'hZip' for 'Proxy', where+the list of labels does not have to include Label+(as in @ts'@)++>>> let ts = Proxy :: Proxy ["x","y"]+>>> let ts' = Proxy :: Proxy [Label "x",Label "y"]+>>> let vs = Proxy :: Proxy [Int,Char]++>>> :t zipTagged ts Proxy+zipTagged ts Proxy :: Proxy '[Tagged "x" y, Tagged "y" y1]++>>> :t zipTagged ts vs+zipTagged ts vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]+++And and the case when hZip does the same thing:++>>> :t zipTagged ts' vs+zipTagged ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]++>>> :t hZip ts' vs+hZip ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char]++-}+zipTagged :: (MapLabel ts ~ lts,+              HZip Proxy lts vs tvs)+      => Proxy ts -> proxy vs -> Proxy tvs+zipTagged _ _ = Proxy+#endif++++class HZipRecord x y xy | x y -> xy, xy -> x y where+    hZipRecord :: Record x -> Record y -> Record xy+    hUnzipRecord :: Record xy -> (Record x,Record y)+++instance HZipRecord '[] '[] '[] where+    hZipRecord _ _ = emptyRecord+    hUnzipRecord _ = (emptyRecord, emptyRecord)++instance HZipRecord as bs abss+       => HZipRecord (Tagged x a ': as) (Tagged x b ': bs) (Tagged x (a,b) ': abss) where+    hZipRecord (Record (Tagged a `HCons` as)) (Record (Tagged b `HCons` bs)) =+        let Record abss = hZipRecord (Record as) (Record bs)+        in Record (Tagged (a,b) `HCons` abss)+    hUnzipRecord (Record (Tagged (a,b) `HCons` abss)) =+        let (Record as, Record bs) = hUnzipRecord (Record abss)+        in (Record (Tagged a `HCons` as), Record (Tagged b `HCons` bs))+++-- | instead of explicit recursion above, we could define HZipRecord in+-- terms of 'HZipList'. While all types are inferred, this implementation+-- is probably slower, so explicit recursion is used in the 'HZip' 'Record'+-- instance.+hZipRecord2 x y = hMapTaggedFn (hZipList (recordValues x) (recordValues y))+        `asLabelsOf` x `asLabelsOf` y++hUnzipRecord2 xy = let (x,y) = hUnzipList (recordValues xy)+                 in (hMapTaggedFn x `asLabelsOf` xy, hMapTaggedFn y `asLabelsOf` xy)+++{- | similar to 'asTypeOf':++>>> let s0 = Proxy :: Proxy '["x", "y"]+>>> let s1 = Proxy :: Proxy '[Label "x", Label "y"]+>>> let s2 = Proxy :: Proxy '[Tagged "x" Int, Tagged "y" Char]++>>> let f0 r = () where _ = r `asLabelsOf` s0+>>> let f1 r = () where _ = r `asLabelsOf` s1+>>> let f2 r = () where _ = r `asLabelsOf` s2++>>> :t f0+f0 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++>>> :t f1+f1 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++>>> :t f2+f2 :: r '[Tagged "x" v, Tagged "y" v1] -> ()++-}+asLabelsOf :: (HAllTaggedLV x, SameLabels x y, SameLength x y) => r x -> s y -> r x+asLabelsOf = const
+ hlist/Data/HList/RecordPuns.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoPolyKinds #-}+{- | Description : quasiquoter inspired by -XNamedFieldPuns -}+module Data.HList.RecordPuns (+    -- $ex+    pun++    ) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.HList.Record+import Data.HList.FakePrelude+import Data.List+import Data.HList.HList++{- $ex++>>> :set -XQuasiQuotes -XViewPatterns++[@patterns@]++>>> let y = Label :: Label "y"+>>> let x = Label :: Label "x"+>>> [pun| x y |] <- return (x .=. 3 .*. y .=. "hi" .*. emptyRecord)+>>> print (x,y)+(3,"hi")++[@expressions@]++Compare with the standard way to construct records above++>>> let x = 3; y = "hi"+>>> [pun|x y|]+Record{x=3,y="hi"}++[@nesting@]++Nesting is supported. Variables inside+@{ }@ and @( )@ are one level deeper, like the built-in syntax.+Furthermore the outer @{ }@ can be left out because @[pun|{x}|]@ is more+cluttered than @[pun|x|]@.+More concretely the pattern:+++> let [pun| ab@{ a b } y z c{d} |] = x++is short for:++> let ab = x.ab+>     a = x.ab.a+>     b = x.ab.b+>     y = x.y+>     z = x.z+>     -- c is not bound+>     d = x.c.d++Where here `.` is a left-associative field lookup (as it is in other languages).++The pun quasiquoter can also be used in an expression context:++> let mkX ab a b y z d = [pun| ab@{ a b } y z c{d} |]+>     x = mkX ab b y z d++Here `mkX` includes @ab a b y z d@. @ab@ needs to be a record, and if it has+fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ (via+'hLeftUnion' = '.<++.') . In other words,++> let mkX ab_ a b y z d = let ab = [pun| a b |] .<++. ab_+>                               in [pun| ab y z c{d} |]++For patterns, any order and additional fields are allowed if @{ }@ is used,+just as in built-in record syntax. But it is often necessary to restrict the+order and number of fields, such as if the record is a 'hRearrange' of a 'hLeftUnion'.+So use @( )@ instead:++> let [pun| (x _ y{}) |] = list+> -- desugars to something like:+> Record ((Tagged x :: Tagged "x" s1) `HCons`+>         (Tagged _ :: Tagged t   s2) `HCons`+>         (Tagged _ :: Tagged "y" s3) `HCons`+>          HNil) = list++Note that this also introduces the familiar wild card pattern (@_@),+and shows again how to ensure a label is present but not bind a variable+to it.++For comparison, here are three equivalent ways to define variables `x` and `y`++> let [pun| x y{} |] = r+> let [pun|{ x y{} }|] = r -- or this+> let x = r .!. (Label :: Label "x")+>     y = constrainType (r .!. (Label :: Label "y"))+>     constrainType :: Record t -> Record t+>     constrainType = id++See also @examples/pun.hs@. In @{}@ patterns, @pun@ can work with+'Variant' too.++-}+++-- | requires labels to be promoted strings (kind Symbol), as provided by+-- "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@),+-- or "Data.HList.Labelable"+pun :: QuasiQuoter+pun = QuasiQuoter {+    quotePat = suppressWarning mp . parseRec,+    quoteExp = suppressWarning me . parseRec,+    quoteDec  = error "Data.HList.RecordPuns.quoteDec",+    quoteType = error "Data.HList.RecordPuns.quoteType"+ }+++-- | the warning about @implicit {} added@ doesn't+-- make sense at top level (but it does if you say+-- have  [pun| x @ y |]+suppressWarning f (V a) = f (C [V a])+suppressWarning f x = f x++-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2),+-- where x1 = Label :: Label "x1"+extracts xs = do+    record <- newName "record"+    -- to fix #5 I could comment out the ensureLength below+    lamE [varP record] $ tupE+            [ [| $(varE record) .!. $label  |]+                | x <- xs,+                let label = [| Label :: Label $(litT (strTyLit x)) |],+                x /= "_"+                ]++mkPair :: String -> ExpQ -> ExpQ+mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |]++++me :: Tree -> ExpQ+me (C as) = foldr (\(l,e) acc -> [| $(mkPair l e) .*. $acc |]) [| emptyRecord |] (mes as)+me (D _as) = error "Data.HList.RecordPuns.mp impossible"+me a = do+    reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a+    me (C [a])++mes :: [Tree] -> [(String, ExpQ)]+mes (V a : V "@": b : c) = (a, [| $(me b) `hLeftUnion` $(dyn a) |]) : mes c+mes (V a : C b : c)      = (a, me (C b)) : mes c+mes (V a : D b : c)      = (a, me (C b)) : mes c+mes (V a : b)            = (a, varE (mkName a)) : mes b+mes [] = []+mes inp = error $ "Data.HList.RecordPuns.mes: cannot translate remaining:" +++                        show (map ppTree inp)++mp :: Tree -> PatQ+mp (C as) =+    let extractPats = mps as+        tupleP = tupP [ p | (binding, p) <- extractPats, binding /= "_" ]+    in viewP (extracts (map fst extractPats)) tupleP+++mp (D as) = conP 'Record+  [foldr ( \ (n,p) xs -> conP 'HCons+                [ let ty+                          | n == "_"  = [| undefined :: Tagged anyLabel t |]+                          | otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |]+                  in viewP [| \x -> x `asTypeOf` $ty |]+                      (conP 'Tagged [p]),+                xs])+          (conP 'HNil [])+          (mps as)]+mp a = do+    reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a+    mp (C [a])++mps :: [Tree] -> [(String, PatQ)]+mps (V a : V "@" : b : c) = (a, asP (mkName a) (mp b)) :  mps c+mps (V a : C b : c) = (a, mp (C b)) : mps c+mps (V a : D b : c) = (a, mp (D b)) : mps c+mps (V "_" : b) = ("_", wildP) : mps b+mps (V a : b) = (a, varP (mkName a)) : mps b+mps [] = []+mps inp = error $ "Data.HList.RecordPuns.mps: cannot translate remaining pattern:" +++                        show (map ppTree inp)++data Tree = C [Tree] -- ^ curly @{ }@+          | D [Tree] -- ^ @(  )@+          | V String -- ^ variable+  deriving Show++{- |++>>> parseRec "{ a b c {d e f}  } d"+C [C [V "a",V "b",V "c",C [V "d",V "e",V "f"]],V "d"]++>>> ppTree $ parseRec "{a b c {d e {} f @ g}}"+"{a b c {d e {} f @ g}}"++>>> ppTree $ parseRec "a b c {d e {} f @ g}"+"{a b c {d e {} f @ g}}"++>>> ppTree $ parseRec "(a b { (d) e } )"+"(a b {(d) e})"++-}+parseRec :: String -> Tree+parseRec str = case parseRec' 0 0 [[]] $ lexing str of+    [x] -> x -- avoid adding another layer if possible+    x -> C (reverse x)++parseRec' :: Int -> Int -> [[Tree]] -> [String] -> [Tree]+parseRec' n m accum  ("{" : rest)  = parseRec' (n+1) m ([] : accum) rest+parseRec' n m accum  ("(" : rest)  = parseRec'  n (m+1) ([] : accum) rest+parseRec' n m (a:b:c) ("}" : rest) = parseRec' (n-1) m ((C (reverse a) : b) : c)  rest+parseRec' n m (a:b:c) (")" : rest) = parseRec' n (m-1) ((D (reverse a) : b) : c)  rest+parseRec' n m (b:c) (a   : rest)+         | a `notElem` ["{","}","(",")"] = parseRec' n m   ((V a : b) : c) rest+parseRec' 0 0 (a:_) []             = a+parseRec' _ _ accum e              = error ("Data.HList.RecordPuns.parseRec' unexpected: " ++ show e+                                            ++ "\n parsed:" ++ show (reverse accum))++ppTree :: Tree -> String+ppTree (C ts) = "{" ++ unwords (map ppTree ts) ++ "}"+ppTree (D ts) = "(" ++ unwords (map ppTree ts) ++ ")"+ppTree (V x)  = x++lexing = unfoldr (\v -> case lex v of+                    ("", "") : _ -> Nothing+                    e : _ -> Just e+                    _ -> Nothing)
+ hlist/Data/HList/RecordU.hs view
@@ -0,0 +1,434 @@+{- | Description: records where elements are stored in unboxed arrays++The public interface is exported from <Data-HList-CommonMain.html#t:RecordU RecordU>++-}+module Data.HList.RecordU where++import Data.Array.Unboxed+import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.HList++import Data.HList.HArray+import LensDefs++import Data.HList.Labelable++import Unsafe.Coerce++-- * Type definitions+-- ** RecordUS++{- | 'RecordUS' is stored as a 'HList' of 'RecordU' +to allow the 'RecordUS' to contain elements of different+types, so long all of the types can be put into an unboxed+array ('UArray').++It is advantageous (at least space-wise) to sort the record to keep+elements with the same types elements adjacent. See 'SortForRecordUS'+for more details.  -}+newtype RecordUS (x :: [*]) =+    RecordUS Any -- ^ Any here is the @HList u@+                 -- given @'RecordUSCxt' x u@++-- | connect the unpacked @x@ representation with the+-- corresponding list of RecordU @u@ representation.+class RecordUSCxt (x :: [*]) (u :: [*]) | x -> u, u -> x where+  {- | @O(1)@ should be possible to implement this without+  unsafeCoerce, but we want to hide the @u@ parameter _and_+  keep the RecordUSCxt as a class (instead of a type+  family) because of 'HEq'. In some cases it is possible+  to have instances that do not actually respect the functional+  dependency, but this should be safe if the check is not+  disabled (by using @-XDysfunctionalDependencies@+  <https://phabricator.haskell.org/D69>, or ghc-7.6) -}+  recordUSToHList :: RecordUS x -> HList u+  recordUSToHList (RecordUS x) = unsafeCoerce x++  -- | @O(1)@ should be possible to implement this without+  -- unsafeCoerce+  hListToRecordUS :: HList u -> RecordUS x+  hListToRecordUS x = RecordUS (unsafeCoerce x)++-- | the only instance+instance (HGroupBy EqTagValue x g, HMapUnboxF g u) => RecordUSCxt x u++data EqTagValue+instance HEqByFn EqTagValue+instance (txv ~ Tagged x v,+          tyw ~ Tagged y w,+          HEq v w b) => HEqBy EqTagValue txv tyw b++-- | proof that @'hMap' 'UnboxF' :: r xs -> r us@ can determine+-- @xs@ from @us@ and @us@ from @xs@+class HMapUnboxF (xs :: [*]) (us :: [*]) | xs -> us, us -> xs+instance HMapUnboxF '[] '[]+instance HMapUnboxF xs us => HMapUnboxF (HList x ': xs) (RecordU x ': us)+++instance (RecordUSCxt x u, Show (HList u)) => Show (RecordUS x) where+    showsPrec n r = ("RecordUS " ++) . showsPrec n (recordUSToHList r)++-- ** RecordU++{- | A type which behaves similarly to 'Record', except+all elements must fit in the same 'UArray'. A consequence of+this is that @RecordU@ has the following properties:++* it is strict in the element types++* it cannot do type-changing updates of 'RecordU', except if+  the function applies to all elements++* it probably is slower to update the very first elements+  of the 'RecordU'++The benefit is that lookups should be faster and records+should take up less space. However benchmarks done with+a slow 'HNat2Integral' do not suggest that RecordU is+faster than Record.+-}+newtype RecordU l = RecordU (UArray Int (GetElemTy l))++type family GetElemTy (x :: [*]) :: *+type instance GetElemTy (Tagged label v ': rest) = v++deriving instance (Show (UArray Int (GetElemTy l))) => Show (RecordU l)+deriving instance (Read (UArray Int (GetElemTy l))) => Read (RecordU l)+deriving instance (Eq  (UArray Int (GetElemTy l))) => Eq  (RecordU l)+deriving instance (Ord (UArray Int (GetElemTy l))) => Ord (RecordU l)++{- | Reorders a 'Record' such that the 'RecordUS' made from it takes up+less space++'Bad' has alternating Double and Int fields++>>> bad+Record{x=1.0,i=2,y=3.0,j=4}++4 arrays containing one element each are needed when this+Record is stored as a RecordUS++>>> recordToRecordUS bad+RecordUS H[RecordU (array (0,0) [(0,1.0)]),RecordU (array (0,0) [(0,2)]),RecordU (array (0,0) [(0,3.0)]),RecordU (array (0,0) [(0,4)])]++It is possible to sort the record++>>> sortForRecordUS bad+Record{x=1.0,y=3.0,i=2,j=4}++This allows the same content to be stored in+two unboxed arrays++>>> recordToRecordUS (sortForRecordUS bad)+RecordUS H[RecordU (array (0,1) [(0,1.0),(1,3.0)]),RecordU (array (0,1) [(0,2),(1,4)])]++-}+class SortForRecordUS x x' | x -> x' where+    sortForRecordUS :: Record x -> Record x'++instance SortForRecordUS '[] '[] where+    sortForRecordUS = id++instance (HPartitionEq EqTagValue x (x ': xs) xi xo,+          SortForRecordUS xo xo',+          sorted ~ HAppendListR xi xo',+          HAppendList xi xo') =>+  SortForRecordUS (x ': xs) sorted where+  sortForRecordUS (Record xs) = Record (hAppendList xi xo')+    where+      f  = Proxy :: Proxy EqTagValue+      x1 = Proxy :: Proxy x+      (xi,xo) = hPartitionEq f x1 xs+      Record xo' = sortForRecordUS (Record xo)++-------------------------------------------------------------- +-- * Lookup++-- | works expected. See examples attached to 'bad'.+instance (HFindLabel l r n,+          HLookupByHNatUS n u (Tagged l v),+          HasField l (Record r) v,+          RecordUSCxt r u) =>+  HasField l (RecordUS r) v where+  hLookupByLabel _ u = case hLookupByHNatUS n (recordUSToHList u) of Tagged v -> v+    where n = Proxy :: Proxy n++class HLookupByHNatUS (n :: HNat) (us :: [*]) (e :: *) | n us -> e where+  hLookupByHNatUS :: Proxy n -> HList us -> e++class HLookupByHNatUS1 (r :: Either HNat HNat) (n :: HNat) (u :: [*]) (us :: [*]) (e :: *)+        | r n u us -> e where+  hLookupByHNatUS1 :: Proxy r -> Proxy n -> RecordU u -> HList us -> e++instance (r ~ HSubtract (HLength u) n,+          RecordU u ~ ru,+          HLookupByHNatUS1 r n u us e) =>+  HLookupByHNatUS n (ru ': us) e where+  hLookupByHNatUS n (HCons u us) = hLookupByHNatUS1 (Proxy :: Proxy r) n u us++instance (HNat2Integral n,+         HLookupByHNatR n u ~ le,+         le ~ Tagged l e,+         IArray UArray e,+         e ~ GetElemTy u) => HLookupByHNatUS1 (Left t) n u us le where+  hLookupByHNatUS1 _ n (RecordU u) _us = Tagged (u ! hNat2Integral n)++instance HLookupByHNatUS t us e => HLookupByHNatUS1 (Right t) n u us e where+  hLookupByHNatUS1 _ _ _ = hLookupByHNatUS (Proxy :: Proxy t)++-- | @HSubtract a b@ is @Left (a-b)@, @Right (b-a)@ or @Right HZero@+type family HSubtract (n1 :: HNat) (n2 :: HNat) :: Either HNat HNat++type instance HSubtract HZero HZero = Right HZero+type instance HSubtract (HSucc x) (HSucc y) = HSubtract x y+type instance HSubtract HZero (HSucc y) = Right (HSucc y)+type instance HSubtract (HSucc y) HZero = Left (HSucc y)+++++-------------------------------------------------------------- +-- * Conversion of RecordUS++-- ** with the actual representation++-- | @Iso (HList s) (HList t) (RecordUS a) (RecordUS b)@+recordUS r = iso hListToRecordUS recordUSToHList r++{- | @Iso (HList s) (RecordUS a)@++@s@ is a HList of 'RecordU' while @a :: [*]@+is list of @Tagged label value@++-}+recordUS' r = isSimple recordUS r++-- ** with 'Record'++-- | @view unboxedS@ or @^. unboxedS@ are preferred+recordToRecordUS :: forall x g u.+   (HMapCxt HList UnboxF g u,+    HMapUnboxF g u,+    HGroupBy EqTagValue x g,+    RecordUSCxt x u)+   => Record x -> RecordUS x+recordToRecordUS (Record x) = hListToRecordUS u+  where+    u :: HList u+    u = hMap UnboxF g ++    g :: HList g+    g = hGroupBy (Proxy :: Proxy EqTagValue) x++-- | @^. from unboxedS@ is preferred+recordUSToRecord :: forall u g x.+  (HConcatFD g x,+   HMapCxt HList BoxF u g,+   HMapUnboxF g u,+   RecordUSCxt x u+  ) => RecordUS x -> Record x+recordUSToRecord rus = Record (hConcatFD g)+  where+    g :: HList g+    g = hMap BoxF (recordUSToHList rus)++-- | @Iso (Record x) (Record y) (RecordUS x) (RecordUS y)@+unboxedS r = iso recordToRecordUS recordUSToRecord r++-- | @Iso' (Record x) (RecordUS x)@+unboxedS' r = isSimple unboxedS r++++-- | all elements of the list have the same type+class ElemTyEq (xs :: [*])++instance + (t1v ~ Tagged t1 v,+  t2v ~ Tagged t2 v,  +  ElemTyEq (tv2 ': rest)) =>+  ElemTyEq (tv1 ': tv2 ': rest)++instance t1v ~ Tagged t v => ElemTyEq (t1v ': rest)+instance ElemTyEq '[]+++instance (IArray UArray v,+          v ~ GetElemTy ls,+          HFindLabel l ls n,+          HNat2Integral n)+    => HasField l (RecordU ls) v where+  hLookupByLabel _ (RecordU ls) = ls ! hNat2Integral (Proxy :: Proxy n)+++instance (r ~ r',+          v ~ GetElemTy r,+          HFindLabel l r n,+          HNat2Integral n,+          IArray UArray v,+          HasField l (Record r') v)+    => HUpdateAtLabel RecordU l v r r' where+  hUpdateAtLabel _ v (RecordU r) = RecordU (r // [(hNat2Integral (Proxy :: Proxy n), v)])+++{- | analogous flip '//'. Similar to '.<++.', except it is restricted+to cases where the left argument holds a subset of elements.++-}+class HUpdateMany lv rx where+    hUpdateMany :: Record lv -> rx -> rx++instance (RecordValues lv,+          HList2List (RecordValuesR lv) v,+          HFindMany (LabelsOf lv) (LabelsOf r) ixs,+          IArray UArray v,+          v ~ GetElemTy r,+          HNats2Integrals ixs) =>+  HUpdateMany lv (RecordU r) where+  hUpdateMany lv (RecordU r) = RecordU (r // (zip ixs (hList2List (recordValues lv))))+     where ixs = hNats2Integrals (Proxy :: Proxy ixs)++-- | implementation in terms of '.<++.'+instance (HLeftUnion lv x lvx,+          HRLabelSet x,+          HLabelSet (LabelsOf x),+          HRearrange (LabelsOf x) lvx x)+  => HUpdateMany lv (Record x) where+    hUpdateMany lv x = hRearrange' (lv .<++. x)++-- | behaves like @map 'HFind'@+class HFindMany (ls :: [k]) (r :: [k]) (ns :: [HNat]) | ls r  -> ns+instance (HFind l r n,+          HFindMany ls r ns) => HFindMany (l ': ls) r (n ': ns)++instance HFindMany '[] r '[]++instance (ApplyAB f (GetElemTy x) (GetElemTy y),+          IArray UArray (GetElemTy y),+          IArray UArray (GetElemTy x)) => HMapAux RecordU f x y where+    hMapAux f (RecordU x) = RecordU (amap (applyAB f) x)++-- | 'hMap' specialized to 'RecordU'+hMapRU :: HMapCxt RecordU f x y => f -> RecordU x -> RecordU y+hMapRU f = hMap f+++-- | @Iso (Record x) (Record y) (RecordU x) (RecordU y)@+unboxed :: forall x y f p.+  (Profunctor p,+   Functor f,+   RecordToRecordU x,+   RecordUToRecord y)+  => RecordU x `p` f (RecordU y)+  -> Record x `p` f (Record y)+unboxed r = iso recordToRecordU recordUToRecord r++-- | @Iso' (Record x) (RecordU x)@+unboxed' x = isSimple unboxed x+++class RecordToRecordU x where+    recordToRecordU :: Record x -> RecordU x++instance (+    RecordValues x,+    HList2List (RecordValuesR x) (GetElemTy x),+    HNat2Integral n,+    HLengthEq x n,+    IArray UArray (GetElemTy x)+   ) => RecordToRecordU x where+  recordToRecordU (rx@(Record x)) = RecordU $ listArray+          (0, hNat2Integral (hLength x) - 1)+          (hList2List (recordValues rx))+ +class RecordUToRecord x where+    recordUToRecord :: RecordU x -> Record x++instance (+    HMapCxt HList TaggedFn (RecordValuesR x) x,+    IArray UArray (GetElemTy x),+    HList2List (RecordValuesR x) (GetElemTy x) +  ) => RecordUToRecord x where+  recordUToRecord (RecordU b) = case list2HList $ elems b of+          Nothing -> error "Data.HList.RecordU.recordUToRecord impossibly too few elements"+          Just y0 -> Record $ hMap TaggedFn (y0 :: HList (RecordValuesR x))++++-- * definitions for doctest examples+type Bad =+         [Tagged "x" Double,+          Tagged "i" Int,+          Tagged "y" Double,+          Tagged "j" Int]++{- | HasField instances++[@RecordUS@]++>>> let r = recordToRecordUS (sortForRecordUS bad)+>>> let s = recordToRecordUS bad++>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let i = Label :: Label "i"+>>> let j = Label :: Label "j"++>>> (r .!. x, r .!. i, r .!. y, r .!. j)+(1.0,2,3.0,4)++>>> (s .!. x, s .!. i, s .!. y, s .!. j)+(1.0,2,3.0,4)+++[@RecordU@]++>>> let t = recordToRecordU bad1+>>> (t .!. x, t .!. y)+(1.0,2.0)++>>> hUpdateAtLabel x 3 t .!. x+3.0++-}+bad :: Record Bad+bad = Tagged 1 .*. Tagged 2 .*. Tagged 3 .*. Tagged 4 .*. emptyRecord++bad1 :: Record [Tagged "x" Double, Tagged "y" Double]+bad1 = Tagged 1 .*. Tagged 2 .*. emptyRecord++-- * Implementation Details++data UnboxF = UnboxF+instance (hx ~ HList x, ux ~ RecordU x,+          RecordToRecordU x) =>+  ApplyAB UnboxF hx ux where+  applyAB _ = recordToRecordU . Record++data BoxF = BoxF++instance (ux ~ RecordU x,+         hx ~ HList x,+         RecordUToRecord x) =>+  ApplyAB BoxF ux hx where+  applyAB _ ux = case recordUToRecord ux of Record hx -> hx+++-- | make a @Lens' (RecordU s) a@+instance (s ~ t, a ~ b,+          IArray UArray a, a ~ GetElemTy s,+          HLensCxt x RecordU s t a b)+        => Labelable x RecordU s t a b where+            type LabelableTy RecordU = LabelableLens+            hLens' x = hLens x++{- TODO+instance Labelable x RecordUS to p f s t a b where+instance (r ~ r', HasField l (Record r) v)+      => HUpdateAtLabel RecordUS l v r r' where+  hUpdateAtLabel = error "recordus hupdateatlabel"++Benchmarks+-}
+ hlist/Data/HList/TIC.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE CPP #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Type-indexed co-products. The public interface is exposed+   in <Data-HList-CommonMain.html#t:TIC CommonMain#TIC>++   (There are other ways: see ConsUnion.hs, for example)+-}++module Data.HList.TIC where++import Data.HList.TIP+import Data.HList.FakePrelude+import Data.HList.HListPrelude++import Data.HList.Record+import Data.HList.Variant+import Data.HList.HList++import Data.HList.HArray++import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif+import Text.ParserCombinators.ReadP+import LensDefs++-- --------------------------------------------------------------------------+-- | A datatype for type-indexed co-products. A 'TIC' is just a 'Variant',+-- where the elements of the type-level list @\"l\"@ are in the form+-- @Tagged x x@.++newtype TIC (l :: [*]) = TIC (Variant l)++deriving instance Eq (Variant l) => Eq (TIC l)+deriving instance Ord (Variant l) => Ord (TIC l)+deriving instance Ix (Variant l) => Ix (TIC l)+deriving instance Bounded (Variant l) => Bounded (TIC l)+deriving instance Enum (Variant l) => Enum (TIC l)+deriving instance Monoid (Variant l) => Monoid (TIC l)+deriving instance Semigroup (Variant l) => Semigroup (TIC l)+++instance HMapAux Variant f xs ys => HMapAux TIC f xs ys where+    hMapAux f (TIC a) = TIC (hMapAux f a)++-- | @Iso (TIC s) (TIC t) (Variant s) (Variant t)@+--+-- 'typeIndexed' may be more appropriate+ticVariant x = isoNewtype (\(TIC a) -> a) TIC x++-- | @Iso' (TIC s) (Variant s)@+ticVariant' x = isSimple ticVariant x+++-- --------------------------------------------------------------------------++{- | Conversion between type indexed collections ('TIC' and 'TIP')+and the corresponding collection that has other label types ('Variant'+and 'Record' respectively)++See 'typeIndexed''++-}+class TypeIndexed r tr | r -> tr, tr -> r where+    -- | @Iso (r s) (r t) (tr a) (tr b)@+    typeIndexed :: forall p f s t a b.+       (TypeIndexedCxt s t a b, Profunctor p, Functor f) =>+      p (tr (TagR a)) (f (tr (TagR b))) -> p (r s) (f (r t))++type TypeIndexedCxt s t a b =+ (HMapCxt HList TaggedFn b t,+  RecordValues s, RecordValues t,+  a ~ RecordValuesR s,+  b ~ RecordValuesR t,+  SameLabels s t,+  SameLength s t,+  SameLength b a,+  {- to use castVariant instead of unsafeCastVariant+  RecordValuesR (TagR a) ~ a,+  RecordValuesR (TagR b) ~ b,+  SameLength (TagR a) s,+  SameLength (TagR b) t,+  -}+  Coercible (TagR b) t,+  Coercible (TagR a) s,+  HAllTaggedLV s,+  HRLabelSet t,+  TagUntag a,+  TagUntag b)++instance TypeIndexed Record TIP where+    typeIndexed = sameLength . unlabeled . fromTipHList+      where fromTipHList = iso (TIP . hTagSelf) (\(TIP a) -> hUntagSelf a)++instance TypeIndexed Variant TIC where+    typeIndexed = isoNewtype unsafeCastVariant unsafeCastVariant+                . isoNewtype TIC (\(TIC a) -> a)++{- |++@'Iso'' ('Variant' s) ('TIC' a)@++@'Iso'' ('Record' s) ('TIP' a)@++where @s@ has a type like @'[Tagged \"x\" Int]@, and+@a@ has a type like @'[Tagged Int Int]@.+-}+typeIndexed' x = isSimple typeIndexed x++-- --------------------------------------------------------------------------+-- | Public constructor (or, open union's injection function)++mkTIC' :: forall i l proxy.+         ( HTypeIndexed l+         , MkVariant i i l+         )+      => i+      -> proxy l -- ^ the ordering of types in the @l :: [*]@ matters.+                 -- This argument is intended to fix the ordering+                 -- it can be a Record, Variant, TIP, Proxy+      -> TIC l++mkTIC' i p = TIC (mkVariant (Label :: Label i) i p)++-- | make a TIC that contains one element+mkTIC1 :: forall i. MkVariant i i '[Tagged i i] => i -> TIC '[Tagged i i]+mkTIC1 i = TIC (mkVariant1 (Label :: Label i) i)++-- | make a TIC for use in contexts where the result type is fixed+mkTIC i = mkTIC' i Proxy+++-- --------------------------------------------------------------------------+-- | Public destructor (or, open union's projection function)+instance HasField o (Variant l) (Maybe o) =>+      HasField o (TIC l) (Maybe o) where+    hLookupByLabel l (TIC i) = hLookupByLabel l i+++instance (HasField o (TIC l) mo, mo ~ Maybe o) => HOccurs mo (TIC l) where+    hOccurs = hLookupByLabel (Label :: Label o)+++-- | similar to 'HPrism'+class TICPrism s t a b | s a b -> t, t a b -> s where+  ticPrism :: (SameLength s t, Choice p, Applicative f)+      => (a `p` f b) -> (TIC s `p` f (TIC t))++instance (+    MkVariant b b t,+    HasField a (Variant s) (Maybe a),+    SameLength s t,++    HFindLabel b t n,+    HFindLabel a s n,++    HUpdateAtHNatR n (Tagged b b) s ~ t,+    HUpdateAtHNatR n (Tagged a a) t ~ s++    ) => TICPrism s t a b where+  ticPrism = ticVariant . prism (\b -> mkVariant (Label :: Label b) b Proxy)+      (\s -> case hLookupByLabel (Label :: Label a) s of+          Just a -> Right a+          Nothing -> Left (unsafeCastVariant s :: Variant t))++-- | @Prism' (TIC s) a@+ticPrism' :: forall s t a b. (HPrism a s t a b, a~b, s~t)+  => (forall f p. (Applicative f, Choice p) => (a `p` f b) -> (TIC s `p` f (TIC t)))+ticPrism' = ticVariant . hPrism (Label :: Label a)+++-- --------------------------------------------------------------------------+-- | TICs are not opaque++instance ShowVariant l => Show (TIC l)+ where+  showsPrec _ (TIC v) = ("TIC{"++) . showVariant v . ('}':)+++instance (ReadVariant l, HAllTaggedEq l, HRLabelSet l) => Read (TIC l)+ where+   readsPrec _ = readP_to_S $ do+     _ <- string "TIC{"+     r <- readVariant+     _ <- string "}"+     return (TIC r)+++{- |+> Nothing .*. x = x+> Just a .*. y = mkTIC a+-}+instance (me ~ Maybe e, HOccursNot (Tagged e e) l)+       => HExtend me (TIC l) where+    type HExtendR me (TIC l) = TIC (Tagged (UnMaybe me) (UnMaybe me) ': l)+    Just e .*. _ = TIC (unsafeMkVariant 0 e)+    Nothing .*. TIC x = TIC (extendVariant x)
+ hlist/Data/HList/TIP.hs view
@@ -0,0 +1,560 @@+{-# LANGUAGE CPP #-}++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Type-indexed products.+   The public interface is described in+   <Data-HList-CommonMain.html#t:TIP CommonMain#TIP>+-}++module Data.HList.TIP+  (module Data.HList.TIPtuple,+   module Data.HList.TIP) where+++import Data.HList.HListPrelude+import Data.HList.FakePrelude+import Data.HList.HList+import Data.HList.Record+import Data.HList.HTypeIndexed ()+import Data.HList.TIPtuple+import Data.List (intercalate)+import Data.Array (Ix)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup)+#endif++#if __GLASGOW_HASKELL__ > 710+import Data.Coerce+#endif++import LensDefs++-- --------------------------------------------------------------------------+-- * The newtype for type-indexed products++-- | TIPs are like 'Record', except element \"i\" of the list \"l\"+-- has type @Tagged e_i e_i@+newtype TIP (l :: [*]) = TIP{unTIP:: HList l}++deriving instance Semigroup (HList a) => Semigroup (TIP a)+deriving instance Monoid (HList a) => Monoid (TIP a)+deriving instance Eq (HList a) => Eq (TIP a)+deriving instance (Ord (HList r)) => Ord (TIP r)+deriving instance (Ix (HList r)) => Ix (TIP r)+deriving instance (Bounded (HList r)) => Bounded (TIP r)+++instance HMapOut (HShow `HComp` HUntag) l String => Show (TIP l) where+  showsPrec _ (TIP l) = ("TIPH[" ++)+                              . (intercalate "," (hMapOut (HShow `HComp` HUntag) l) ++)+                              . (']' :)+++mkTIP :: HTypeIndexed l => HList l -> TIP l+mkTIP = TIP++emptyTIP :: TIP '[]+emptyTIP = mkTIP HNil++-- --------------------------------------------------------------------------+-- * Type-indexed type sequences++-- | this constraint ensures that a TIP created by 'mkTIP' has no+-- duplicates+class (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed (l :: [*])++instance (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed l++class HAllTaggedEq (l :: [*])+instance HAllTaggedEq '[]+instance (HAllTaggedEq l, tee ~ Tagged e e') => HAllTaggedEq (tee ': l)++-- --------------------------------------------------------------------------+-- Implementing the HListPrelude interface++instance (HRLabelSet (Tagged e e ': l), HTypeIndexed l) => HExtend e (TIP l)+ where+  type HExtendR e (TIP l) = TIP (Tagged e e ': l)+  e .*. TIP l = mkTIP (HCons (Tagged e) l)++++instance (e ~ e', HasField e (Record l) e') => HasField e (TIP l) e' where+    hLookupByLabel lab (TIP l) = hLookupByLabel lab (Record l)++-- | One occurrence and nothing is left+--+-- This variation provides an extra feature for singleton lists.+-- That is, the result type is unified with the element in the list.+-- Hence the explicit provision of a result type can be omitted.+--++instance (tee ~ Tagged e e) => HOccurs e (TIP '[tee]) where+  hOccurs (TIP (HCons (Tagged e) _)) = e++instance HasField e (Record (x ': y ': l)) e+      => HOccurs e (TIP (x ': y ': l)) where+  hOccurs (TIP l) = Record l .!. (Label :: Label e)+++instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendListR l l'))+           => HAppend (TIP l) (TIP l')+ where+  hAppend (TIP l) (TIP l') = mkTIP (hAppend l l')++type instance HAppendR (TIP l) (TIP l') = TIP (HAppendListR l l')+++-- instance HOccurrence HList e l l' => HOccurrence TIP e l l'+--  where+--   hOccurrence e = TIP . hOccurrence e . unTIP++-- --------------------------------------------------------------------------+-- * Shielding type-indexed operations+-- $note The absence of signatures is deliberate! They all must be inferred.++onRecord f (TIP l) = let Record l' = f (Record l) in mkTIP l'++instance (HDeleteAtLabel Record e v v',+          HTypeIndexed v')+      => HDeleteAtLabel TIP e v v' where+  hDeleteAtLabel e v = onRecord (hDeleteAtLabel e) v+++tipyUpdate  e t  = hTPupdateAtLabel (fromValue e) e t+  where fromValue :: e -> Label e+        fromValue _ = Label++instance (HUpdateAtLabel Record e' e r r',+          HTypeIndexed r',+         e ~ e') => HUpdateAtLabel TIP e' e r r' where+  hUpdateAtLabel l e r = onRecord (hUpdateAtLabel l e) r+++-- | Use 'Labels' to specify the first argument+tipyProject ps t = onRecord (hProjectByLabels ps) t++-- | provides a @Lens' (TIP s) a@. 'hLens'' @:: Label a -> Lens' (TIP s) a@+-- is another option.+#if __GLASGOW_HASKELL__ < 707+tipyLens' x = isSimple tipyLens x -- rejected by GHC-7.10RC1+#else+tipyLens' f s = isSimple (hLens x) f (asTIP s) -- rejected by GHC-7.6.3+  where+    x = getA f+    getA :: (a -> f a) -> Label a+    getA _ = Label++    asTIP :: TIP a -> TIP a+    asTIP = id+#endif++{- | provides a @Lens (TIP s) (TIP t) a b@++When using @set@ (also known as @.~@), 'tipyLens'' can address the+ambiguity as to which field \"a\" should actually be updated.++-}+tipyLens f (TIP s) =+      case hSplitAt (getN s f) (ghc8fix1 s) of+          (x, ta@(Tagged a) `HCons` ys)+             | () <- ghc8fix2 ta ->+              let mkt b = mkTIP (x `hAppendList` (tagSelf b `HCons` ys))+              in mkt <$> f a+  where+    getN :: HFind (Label a) (LabelsOf s) n => HList s -> (a -> f b) -> Proxy n+    getN _ _ = Proxy++    -- without these, tipyLens has a type that has kind variables,+    -- (that end up being * when an actual TIP is provided), leading to+    -- a Properties.LengthIndependent compile error:+    -- .../.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/Data/HList/TIP.hi+    -- Declaration for tipyLens:+    --   Iface type variable out of scope:  k+    -- Cannot continue after interface file error+    ghc8fix1 :: HList (Tagged x x ': xs) -> HList (Tagged x x ': xs)+    ghc8fix1 = id++    ghc8fix2 :: Tagged a a -> ()+    ghc8fix2 _ = ()++++-- | The same as 'tipyProject', except also return the+-- types not requested in the @proxy@ argument+tipyProject2 ps (TIP l) = (mkTIP l',mkTIP l'')+ where+  (l',l'') = h2projectByLabels ps l+++-- --------------------------------------------------------------------------++-- | Subtyping for TIPs++instance SubType (TIP l) (TIP '[])+instance (HOccurs e (TIP l1), SubType (TIP l1) (TIP l2))+      =>  SubType (TIP l1) (TIP (e ': l2))+++-- --------------------------------------------------------------------------+-- * conversion to and from 'HList'++{- | 'TagR' can also be used to avoid redundancy when defining types for TIC and TIP.++>  type XShort = TagR [A,B,C,D]++>  type XLong = [Tagged A A, Tagged B B, Tagged C C, Tagged D D]+++an equivalent FD version, which is slightly better with respect to+simplifying types containing type variables (in ghc-7.8 and 7.6):+<http://stackoverflow.com/questions/24110410/>++With ghc-7.10 (<http://ghc.haskell.org/trac/ghc/ticket/10009>) the FD version is superior+to the TF version:++@+class (UntagR (TagR a) ~ a) => TagUntag a where+    type TagR a :: [*]+    hTagSelf :: HList a -> HList (TagR a)+    hUntagSelf :: HList (TagR a) -> HList a++instance TagUntag '[] where+    type TagR '[] = '[]+    hTagSelf _ = HNil+    hUntagSelf _ = HNil++instance TagUntag xs => TagUntag (x ': xs) where+    type TagR (x ': xs) = Tagged x x ': TagR xs+    hTagSelf (HCons x xs) = Tagged x `HCons` hTagSelf xs+    hUntagSelf (HCons (Tagged x) xs) = x `HCons` hUntagSelf xs++type family UntagR (xs :: [*]) :: [*]+type instance UntagR '[] = '[]+type instance UntagR (x ': xs) = Untag1 x ': UntagR xs+@++Length information should flow backwards++>>> let len2 x = x `asTypeOf` (undefined :: HList '[a,b])+>>> let f = len2 $ hTagSelf (hReplicate Proxy ())+>>> :t f+f :: HList '[Tagged () (), Tagged () ()]++-}+class SameLength a ta => TagUntagFD a ta | a -> ta, ta -> a where+    hTagSelf :: HList a -> HList ta+    hUntagSelf :: HList ta -> HList a++instance TagUntagFD '[] '[] where+    hTagSelf _ = HNil+    hUntagSelf _ = HNil++instance (TagUntagFD xs ys, txx ~ Tagged x x)+      => TagUntagFD (x ': xs) (txx ': ys) where+    hTagSelf (HCons x xs) = Tagged x `HCons` hTagSelf xs+    hUntagSelf (HCons (Tagged x) xs) = x `HCons` hUntagSelf xs++type TagUntag xs = TagUntagFD xs (TagR xs)++-- | Sometimes the type variables available have @TagR@ already applied+-- (ie the lists have elements like @Tagged X X@). Then this abbreviation+-- is useful:+type UntagTag xs = (TagR (UntagR xs) ~ xs, TagUntagFD (UntagR xs) xs)++type family TagR (a :: [*]) :: [*]+type family UntagR (ta :: [*]) :: [*]++type instance TagR '[] = '[]+type instance UntagR '[] = '[]++type instance TagR (x ': xs) = Tagged x x ': TagR xs+type instance UntagR (Tagged y y ': ys) = y ': UntagR ys++type family Untag1 (x :: *) :: *+type instance Untag1 (Tagged k x) = x+++-- | @Iso (TIP (TagR a)) (TIP (TagR b)) (HList a) (HList b)@+tipHList x = iso (\(TIP a) -> hUntagSelf a) (TIP . hTagSelf) x++-- | @Iso' (TIP (TagR s)) (HList a)@+tipHList' x = isSimple tipHList x+++-- * conversion to and from 'Record'++-- | @Iso (TIP s) (TIP t) (Record s) (Record t)@+--+-- 'typeIndexed' may be more appropriate+tipRecord x = isoNewtype (\(TIP a) -> Record a) (\(Record b) -> TIP b) x++-- | @Iso' (TIP (TagR s)) (Record a)@+tipRecord' x = isSimple tipRecord x++-- --------------------------------------------------------------------------+-- * Zip++#if __GLASGOW_HASKELL__ < 800+-- pre-coerce+instance (HZipList (UntagR x) (UntagR y) (UntagR xy),+          UntagTag x, UntagTag y, UntagTag xy,+          SameLengths [x,y,xy],+          HTypeIndexed x, HTypeIndexed y,+          HUnzip TIP x y xy+          -- HTypeIndexed xy is always satisfied given the above+          -- constraints (with a handwaving proof), so don't require+          -- callers of hZip/hUnzip to supply such proof+    ) => HZip TIP x y xy where+  hZip = hZipTIP+++instance (HZipList (UntagR x) (UntagR y) (UntagR xy),+          UntagTag x, UntagTag y, UntagTag xy,+          HTypeIndexed x, HTypeIndexed y,+          SameLengths [x,y,xy]) => HUnzip TIP x y xy where+  hUnzip = hUnzipTIP++#else+-- ghc-7.10.3 has coerce, but rejects these instances+instance (HZipList xL yL xyL,+          lty ~ (HList xyL -> (HList xL,HList yL)),+          Coercible lty (TIP xy -> (TIP x, TIP y)),+          UntagR x ~ xL, TagR xL ~ x, -- `TagR (UntagR x) ~ x` included by UntagTag+          UntagR y ~ yL, TagR yL ~ y,+          UntagR xy ~ xyL, TagR xyL ~ xy,+          SameLengths '[x,y,xy],+          UntagTag x, UntagTag y, UntagTag xy+        ) => HUnzip TIP x y xy where+  hUnzip = coerce (hUnzipList :: lty)++instance (HUnzip TIP x y xy,+          HZipList xL yL xyL,+          lty ~ (HList xL -> HList yL -> HList xyL),+          Coercible lty (TIP x -> TIP y -> TIP xy) ,+          UntagR x ~ xL,+          UntagR y ~ yL,+          UntagR xy ~ xyL,+          UntagTag x, UntagTag y, UntagTag xy+        ) => HZip TIP x y xy where+  hZip = coerce (hZipList :: lty)+#endif++-- | specialization of 'hZip'+hZipTIP (TIP x) (TIP y) = TIP (hTagSelf (hZipList (hUntagSelf x) (hUntagSelf y)))++-- | specialization of 'hUnzip'+hUnzipTIP (TIP xy) = case hUnzipList (hUntagSelf xy) of+  (x,y) -> (mkTIP (hTagSelf x), mkTIP (hTagSelf y))++++-- --------------------------------------------------------------------------+-- * TIP Transform++{- |++Transforming a TIP: applying to a TIP a (polyvariadic) function+that takes arguments from a TIP and updates the TIP with the result.++In more detail: we have a typed-indexed collection TIP and we+would like to apply a transformation function to it, whose argument+types and the result type are all in the TIP. The function should locate+its arguments based on their types, and update the TIP+with the result. The function may have any number of arguments,+including zero; the order of arguments should not matter.++The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009.+<http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html>+The problem is an interesting variation of the keyword argument problem.++Examples can be found in @examples/TIPTransform.hs@ and @examples/TIPTransformM.hs@+-}++class TransTIP op db where+    ttip :: op -> TIP db -> TIP db++instance (HMember (Tagged op op) db b,+          Arity op n,+          TransTIP1 b n op db)+    => TransTIP op db where+    ttip = ttip1 (Proxy ::Proxy b) (Proxy :: Proxy n)++class TransTIP1 (b :: Bool) (n :: HNat) op db where+    ttip1 :: Proxy b -> Proxy n -> op -> TIP db -> TIP db++-- If op is found in a TIP, update the TIP with op+instance HTPupdateAtLabel TIP op op db+    => TransTIP1 True n op db where+    ttip1 _ _ = tipyUpdate++-- If op is not found in a TIP, it must be a function. Try to look up+-- its argument in a TIP and recur.+instance (HMember (Tagged arg arg) db b,+          TransTIP2 b arg op db)+    => TransTIP1 False (HSucc n) (arg -> op) db where+    ttip1 _ _ = ttip2 (Proxy :: Proxy b)++instance Fail (FieldNotFound notfun (TIP db))+      => TransTIP1 False HZero notfun db where+    ttip1 = error "TransTIP1 Fail failed"++class TransTIP2 (b :: Bool) arg op db where+    ttip2 :: Proxy b -> (arg -> op) -> TIP db -> TIP db++instance (HOccurs arg (TIP db),+         TransTIP op db)+   => TransTIP2 True arg op db where+    ttip2 _ f db = ttip (f (hOccurs db)) db++instance Fail (FieldNotFound arg (TIP db))+    => TransTIP2 False arg op db where+    ttip2 = error "TransTIP2 Fail failed"++-- ** Monadic version++{- |++In March 2010, Andrew Frank extended the problem for monadic operations.+This is the monadic version of @TIPTransform.hs@ in the present directory.++This is the TF implementation. When specifying the operation to perform over+a TIP, we can leave it polymorphic over the monad. The type checker+will instantiate the monad based on the context.++-}+class Monad m => TransTIPM m op db where+    ttipM :: op -> TIP db -> m (TIP db)++-- Check to see if the operation is a computation whose result+-- is in the TIP. The type variable m' of the kind *->* below+-- can be instantiated either to a monad type constructor, or (arg->).+instance (Monad m, HMember (Tagged op op) db b,+           Arity (m' op) n,+           TransTIPM1 b n m (m' op) db)+    => TransTIPM m (m' op) db where+    ttipM = ttipM1 (Proxy :: Proxy b) (Proxy :: Proxy n)++class Monad m => TransTIPM1 (b :: Bool) (n :: HNat) m op db where+    ttipM1 :: Proxy b -> Proxy n -> op -> TIP db -> m (TIP db)++-- If op is found in a TIP, update the TIP with op.+-- The type variable m' must be equal to the type of the monad+-- in which the final result is reported.+instance (Monad m, m ~ m', HTPupdateAtLabel TIP op op db)+    => TransTIPM1 True n m (m' op) db where+    ttipM1 _ _ op db = do+         op' <- op+         return $ tipyUpdate op' db++instance (Fail (FieldNotFound op (TIP db)), Monad m)+    => TransTIPM1 False HZero m op db where+    ttipM1 _ _ = error "TransTIPM1 Fail failed"++-- If op is not found in a TIP, it must be a function. Look up+-- its argument in a TIP and recur.+instance (Monad m,+          HMember (Tagged arg arg) db b,+          TransTIPM2 b m arg op db)+    => TransTIPM1 False (HSucc n) m (arg-> op) db where+    ttipM1 _ _ = ttipM2 (Proxy :: Proxy b)+++class TransTIPM2 (b :: Bool) m arg op db where+    ttipM2 :: Proxy b -> (arg -> op) -> TIP db -> m (TIP db)++instance (HOccurs arg (TIP db), TransTIPM m op db)+      => TransTIPM2 True m arg op db where+    ttipM2 _ f db = ttipM (f (hOccurs db)) db+++instance Fail (FieldNotFound op (TIP db))+    => TransTIPM2 False m arg op db where+    ttipM2 _ _ = error "TransTIPM1 Fail failed"++-- --------------------------------------------------------------------------++-- tests for tipyTuple. These only work if tipyTuple is compiled+-- in a module that has NoMonoLocalBinds enabled+_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Char, Bool)+_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Bool, Char)+++-- --------------------------------------------------------------------------++-- * Sample code++{- $setup++[@Assume@]++>>> import Data.HList.TypeEqO+>>> import Data.HList.FakePrelude+>>> import Data.HList.HOccurs++>>> :{+newtype Key    = Key Integer deriving (Show,Eq,Ord)+newtype Name   = Name String deriving (Show,Eq)+data Breed     = Cow | Sheep deriving (Show,Eq)+newtype Price  = Price Float deriving (Show,Eq,Ord)+data Disease   = BSE | FM deriving (Show,Eq)+type Animal =  TagR '[Key,Name,Breed,Price]+:}++>>> :{+let myTipyCow :: TIP Animal -- optional+    myTipyCow = Key 42 .*.  Name "Angus" .*.  Cow .*.  Price 75.5 .*. emptyTIP+    animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key+    animalKey = hOccurs+:}++-}++{- $sessionlog+[@Session log@]++>>> :t myTipyCow+myTipyCow+  :: TIP+       '[Tagged Key Key, Tagged Name Name, Tagged Breed Breed,+         Tagged Price Price]++>>> hOccurs myTipyCow :: Breed+Cow++>>> BSE .*. myTipyCow+TIPH[BSE,Key 42,Name "Angus",Cow,Price 75.5]++++>>> Sheep .*. hDeleteAtLabel (Label::Label Breed) myTipyCow+TIPH[Sheep,Key 42,Name "Angus",Price 75.5]++>>> tipyUpdate Sheep myTipyCow+TIPH[Key 42,Name "Angus",Sheep,Price 75.5]+++>>> tipyProject2 (Proxy :: Labels '[Name,Price]) myTipyCow+(TIPH[Name "Angus",Price 75.5],TIPH[Key 42,Cow])++>>> tipyProject (Proxy :: Labels '[Name,Price]) myTipyCow+TIPH[Name "Angus",Price 75.5]++-}+++{- $sessionlog2++Don't bother repeating the type error:+++>>> Sheep .*. myTipyCow+...+...No instance for (Fail (DuplicatedLabel (Label Breed)))+...++-}
+ hlist/Data/HList/TIPtuple.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE NoTypeFamilies #-}+{- | Description: TIP functions needing different LANGUAGE extensions++While NoMonoLocalBinds could be enabled in TIP.hs, the ghc manual warns+"type inference becomes less predicatable if you do so. (Read the papers!)".+These definitions don't need type families, putting these definitions in+a separate module avoids that mess.++XXX these should be implemented in terms of 'HTuple' and 'tipyProject',+which means adding+-}+module Data.HList.TIPtuple where++import Data.HList.HOccurs++{- | project a TIP (or HList) into a tuple++@tipyTuple' x = ('hOccurs' x, hOccurs x)@++behaves similarly, except @tipyTuple@ excludes+the possibility of looking up the same element+twice, which allows inferring a concrete type+in more situations. For example++> (\x y z -> tipyTuple (x .*. y .*. emptyTIP) `asTypeOf` (x, z)) () 'x'++has type @Char -> ((), Char)@. tipyTuple' would+need a type annotation to decide whether the type+should be @Char -> ((), Char)@ or @() -> ((), ())@++-}+tipyTuple l = t (,) `asTypeOf` t (flip (,))+  where+  t f = case hOccursRest l of+     (x, ly) -> case hOccursRest ly of+         (y, _) -> f x y++tipyTuple3 l = t (,,)+          `asTypeOf` t (\a b c -> (b,c,a))+          `asTypeOf` t (\a b c -> (c,a,b))+  where+  t f = case hOccursRest l of+    (x, lyz) -> case hOccursRest lyz of+       (y, lz) -> case hOccursRest lz of+          (z, _) -> f x y z++tipyTuple4 l = t (,,,)+          `asTypeOf` t (\a b c d -> (b,c,d,a))+          `asTypeOf` t (\a b c d -> (c,d,a,b))+          `asTypeOf` t (\a b c d -> (d,a,b,c))+  where+  t f = case hOccursRest l of+    (a, lbcd) -> case hOccursRest lbcd of+       (b, lcd) -> case hOccursRest lcd of+          (c, ld) -> case hOccursRest ld of+             (d, _) -> f a b c d++tipyTuple5 l = t (,,,,)+          `asTypeOf` t (\a b c d e -> (b,c,d,e,a))+          `asTypeOf` t (\a b c d e -> (c,d,e,a,b))+          `asTypeOf` t (\a b c d e -> (d,e,a,b,c))+          `asTypeOf` t (\a b c d e -> (e,a,b,c,d))+  where+  t f = case hOccursRest l of+    (a, lbcde) -> case hOccursRest lbcde of+       (b, lcde) -> case hOccursRest lcde of+          (c, lde) -> case hOccursRest lde of+            (d, le) -> case hOccursRest le of+               (e, _) -> f a b c d e
+ hlist/Data/HList/TypeEqO.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+#if (__GLASGOW_HASKELL__ < 709)+{-# LANGUAGE OverlappingInstances #-}+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}+#endif++{- |+   The HList library++   (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke++   Generic type equality predicate:+   The implementation based on overlapping instances+   The only place where overlapping instances are really used+   besides Label5++-}++module Data.HList.TypeEqO where++import Data.HList.FakePrelude++#if !NEW_TYPE_EQ+instance {-# OVERLAPPING #-} HEq x x True+instance {-# OVERLAPPABLE  #-} False ~ b => HEq x y b+-- instance TypeEq x y HFalse -- would violate functional dependency+#endif++++class TupleType (t :: *) (b :: Bool) | t -> b+instance {-# OVERLAPPING #-} TupleType () True+instance {-# OVERLAPPING #-} TupleType (x,y) True+instance {-# OVERLAPPING #-} TupleType (x,y,z) True+-- Continue for a while+instance {-# OVERLAPPABLE #-} False ~ b => TupleType x b+-- instance TupleType x HFalse -- would violate functional dependency++-- overlaps an instance Show (Proxy t) for convenience+instance {-# OVERLAPPING #-} Show (Proxy True)  where show _ = "HTrue"+instance {-# OVERLAPPING #-} Show (Proxy False) where show _ = "HFalse"++instance {-# OVERLAPPING #-} HNat2Integral n => Show (Proxy (n :: HNat)) where+    show n = "H" ++ show (hNat2Integral n :: Integer)+++instance {-# OVERLAPPABLE #-} hZero ~ HZero => ArityFwd f hZero+instance {-# OVERLAPPING #-} Arity f n => ArityFwd (x -> f) (HSucc n)+++-- | All our keywords must be registered+class IsKeyFN (t :: *) (flag :: Bool) | t-> flag+-- | overlapping/fallback case+instance {-# OVERLAPPABLE #-} (False ~ flag) => IsKeyFN t flag+
+ hlist/Data/HList/Variant.hs view
@@ -0,0 +1,1185 @@+{-# LANGUAGE CPP #-}++{- |+   Description: Variants, i.e., labelled sums, generalizations of Either++   The HList library++   See <Data-HList-CommonMain.html#t:Variant CommonMain#Variant>+   for the public (safe) interface.++   The implementation here follows "Data.Dynamic", though Typeable is not+   needed.++   See @broken/VariantP.hs@ and @broken/VariantOld.hs@ for different approaches+   to open sums.+-}++module Data.HList.Variant where++import Data.HList.FakePrelude+import Data.HList.Record+import Data.HList.HList+import Data.HList.HListPrelude+import Data.HList.HOccurs()+import Data.HList.HArray++import Text.ParserCombinators.ReadP hiding (optional)++import Unsafe.Coerce+import GHC.Exts (Constraint)+#if __GLASGOW_HASKELL__ <= 906+import Data.Semigroup (Semigroup( .. ))+#endif+import Data.Data+import Control.Applicative+import LensDefs+import Control.Monad++-- * Labels for doctests++{- $setup++>>> import Data.HList.RecordPuns+>>> let x = Label :: Label "x"+>>> let y = Label :: Label "y"+>>> let z = Label :: Label "z"+>>> let _left = Label :: Label "left"+>>> let _right = Label :: Label "right"++>>> :set -XQuasiQuotes -XViewPatterns -XDataKinds+++-- * Creating Variants++It is necessary to specify the order in which the fields occur, using+a data type like++>>> let p = Proxy :: Proxy '[Tagged "left" Char, Tagged "right" Int]++Then this argument can be passed into 'mkVariant'++>>> let v = mkVariant _left 'x' p+>>> let w = mkVariant _right 5  p++>>> :t v+v :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w+w :: Variant '[Tagged "left" Char, Tagged "right" Int]+++>>> [v,w]+[V{left='x'},V{right=5}]++-}+++-- ** Alternative: a 'Record' as the Proxy+{- $mkVariant2++The type of mkVariant also allows using a 'Record' as the proxy. For example:++>>> :{+let p2 = [pun| left right |] where+            left = 'a'+            right = (4::Int)+:}++>>> let v2 = mkVariant _left 'x' p2+>>> let w2 = mkVariant _right 5  p2++>>> :t v2+v2 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w2+w2 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> (v2,w2)+(V{left='x'},V{right=5})++-}++-- ** A polymorphic Proxy+{- $mkVariant3++It is also possible to leave the @Char@ and @Int@ as type variables,+and have them inferred.++>>> let p3 = Proxy :: Proxy '[Tagged "left" a, Tagged "right" b]++Using @p3@ takes some care. The following attempt shows the problem:++>>> :{+let v3' = mkVariant _left 'x' p3+    w3' = mkVariant _right (5::Int) p3+:}++>>> :t v3'+v3' :: Variant '[Tagged "left" Char, Tagged "right" b]++>>> :t w3'+w3' :: Variant '[Tagged "left" a, Tagged "right" Int]++Here each use of @p3@ does not constrain the type of the other use.+In some cases those type variables will be inferred from other constraints,+such as when putting the variants into a list++>>> [v3', w3']+[V{left='x'},V{right=5}]++In other cases the other tags will be defaulted to (), at least if `ExtendedDefaultRules` is enabled:++>>> v3'+V{left='x'}++>>> :set -XNoExtendedDefaultRules+>>> v3'+...+...No instance for (Show ...) arising from a use of ‘print’+...+++Another way around this issue is to make sure that the proxy+is bound in a monomorphic pattern. These are patterns that allow+name shadowing.++* @\p -> ...@+* @case e of p -> ...@+* @do p <- e; ...@+* implicit parameters @let ?p = e in ...@+* <http://stackoverflow.com/questions/23899279#23899611 other patterns involved in mutually recursive bindings>++An example of the case:++>>> :{+let (v3,w3) = case p3 of+              p -> (mkVariant _left 'x' p,+                    mkVariant _right (5 :: Int) p)+:}+++>>> :t v3+v3 :: Variant '[Tagged "left" Char, Tagged "right" Int]++>>> :t w3+w3 :: Variant '[Tagged "left" Char, Tagged "right" Int]++-}++-- --------------------------------------------------------------------------+{- |+@Variant vs@ has an implementation similar to 'Dynamic', except the+contained value is one of the elements of the @vs@ list, rather than+being one particular instance of 'Typeable'.++>>> v .!. _right+Nothing++>>> v .!. _left+Just 'x'++In some cases the 'pun' quasiquote works with variants,++>>> let f [pun| left right |] = (left,right)+>>> f v+(Just 'x',Nothing)++>>> f w+(Nothing,Just 5)+++>>> let add1 v = hMapV (Fun succ :: Fun '[Enum] '()) v++>>> f (add1 v)+(Just 'y',Nothing)++>>> f (add1 w)+(Nothing,Just 6)+++-}+data Variant (vs :: [*]) = Variant !Int Any++#if __GLASGOW_HASKELL__ > 707+-- the inferred role is phantom, which is not safe+type role Variant representational+#endif++++-- ** Unsafe operations++-- | This is only safe if the n'th element of vs has type @Tagged t v@+unsafeMkVariant :: Int -- ^ n+                -> v+                -> Variant vs+unsafeMkVariant n a = Variant n (unsafeCoerce a)++{- | Safe when (e ~ e') given that++> Tagged t e ~ HLookupByHNatR n v+> Tagged t' e' ~ HLookupByHNatR n v'++'hUpdateAtLabel' is the safe version++-}+unsafeCastVariant :: Variant v -> Variant v'+unsafeCastVariant (Variant n e) = Variant n e++-- | in ghc>=7.8, 'Data.Coerce.coerce' is probably a better choice+castVariant :: (RecordValuesR v ~ RecordValuesR v',+              SameLength v v') => Variant v -> Variant v'+castVariant = unsafeCastVariant++instance Relabeled Variant where+    relabeled = iso castVariant castVariant++-- | private destructor. This is safe only if the value+-- contained actually has type `e`+unsafeUnVariant :: Variant v -> e+unsafeUnVariant (Variant _ e) = unsafeCoerce e+++{- | This function is unsafe because it can lead to a runtime error+when used together with the 'HExtend' instance (.*.)++>>> print $ (Label :: Label "x") .=. (Nothing :: Maybe ()) .*. unsafeEmptyVariant+V{*** Exception: invalid variant++use 'mkVariant1' instead++-}+unsafeEmptyVariant :: Variant '[]+unsafeEmptyVariant = unsafeMkVariant 0 ()++-- --------------------------------------------------------------------------+-- * Public constructor++class HasField x (Variant vs) (Maybe v) =>+      MkVariant x v vs | x vs -> v where+    mkVariant :: Label x -- ^ the tag+        -> v -- ^ value to be stored+        -> proxy vs -- ^ a helper to fix the ordering and types of the+                    -- potential values that this variant contains.+                    -- Typically this will be a 'Proxy', 'Record' or+                    -- another 'Variant'+        -> Variant vs++mkVariant1 l v = l .=. Just v .*. unsafeEmptyVariant++instance (HFindLabel x vs n,+          HNat2Integral n,+          HasField x (Variant vs) (Maybe v)) =>+    MkVariant x v vs where+  mkVariant _x y _p = unsafeMkVariant (hNat2Integral (Proxy :: Proxy n)) y+  -- done as a one-instance class instead of a function to be able to hide+  -- the 'n' type variable++-- --------------------------------------------------------------------------+-- * Public destructor++{- $note 'hLookupByLabel' (synonym '.!.')++> (.!.)             :: Variant v -> Label x -> Maybe e+> hLookupByLabel    :: Label x -> Variant v -> Maybe e++'hPrism' and 'hLens'' combine this with 'mkVariant'+-}+instance (HasField x (Record vs) a,+          HFindLabel x vs n,+          HNat2Integral n)+  => HasField x (Variant vs) (Maybe a) where+  hLookupByLabel _x (Variant n d)+          | hNat2Integral (Proxy :: Proxy n) == n = Just (unsafeCoerce d)+          | otherwise = Nothing++splitVariant1 :: Variant (Tagged s x ': xs) -> Either x (Variant xs)+splitVariant1 (Variant 0 x) = Left (unsafeCoerce x)+splitVariant1 (Variant n x) = Right (Variant (n-1) x)++-- | x ~ Tagged s t+splitVariant1' :: Variant (x ': xs) -> Either x (Variant xs)+splitVariant1' (Variant 0 x) = Left (unsafeCoerce x)+splitVariant1' (Variant n x) = Right (Variant (n-1) x)++extendVariant :: Variant l -> Variant (e ': l)+extendVariant (Variant m e) = Variant (m+1) e++-- --------------------------------------------------------------------------+-- * Prism++{- | Make a @Prism (Variant s) (Variant t) a b@ out of a Label.++See "Data.HList.Labelable".'hLens'' is a more overloaded version.++Few type annotations are necessary because of the restriction+that `s` and `t` have the same labels in the same order, and to+get \"t\" the \"a\" in \"s\" is replaced with \"b\".++-}+class (SameLength s t, SameLabels s t)+        => HPrism x s t a b+          | x s -> a, x t -> b,    -- lookup+            x s b -> t, x t a -> s -- update+  where+    hPrism :: (Choice p, Applicative f)+        => Label x -> p a (f b) -> p (Variant s) (f (Variant t))+++instance (+    MkVariant x b t,++    HasField x (Variant s) (Maybe a),++    -- labels in the HList are not changed at all:+    -- number, ordering, actual values are all constant+    SameLength s t,+    SameLabels s t,++    -- only the target of the prism can have it's type changed+    H2ProjectByLabels '[Label x] s si so,+    H2ProjectByLabels '[Label x] t ti to,+    so ~ to,++    -- to convince GHC the fundeps are satisfied+    HUpdateAtLabel Variant x b s t,+    HUpdateAtLabel Variant x a t s+   ) => HPrism x s t a b where+    hPrism x = prism (\b -> mkVariant x b Proxy)+                  (\s -> case hLookupByLabel x s of+                    Just a -> Right a+                    Nothing -> Left (unsafeCastVariant s :: Variant t))++++-- --------------------------------------------------------------------------+-- * Read+-- | Variants are not opaque+instance (ShowVariant vs) => Show (Variant vs) where+    showsPrec _ v = ("V{"++) . showVariant v . ('}':)+++-- | helper class for defining the Show instance+class ShowVariant vs where+    showVariant :: Variant vs -> ShowS++instance (ShowLabel l, Show v, ShowVariant (w ': ws))+      => ShowVariant (Tagged l v ': w ': ws) where+    showVariant vs = case splitVariant1 vs of+        Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest+        Right wws -> showVariant wws+      where l = Label :: Label l++instance (ShowLabel l, Show v, lv ~ Tagged l v) => ShowVariant '[lv] where+    showVariant vs = case splitVariant1 vs of+        Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest+        Right _ -> error "invalid variant"+      where l = Label :: Label l++-- --------------------------------------------------------------------------+-- * Show+-- | A corresponding read instance++instance ReadVariant v => Read (Variant v) where+    readsPrec _ = readP_to_S $ do+      _ <- string "V{"+      r <- readVariant+      _ <- string "}"+      return r++class ReadVariant vs where+    readVariant :: ReadP (Variant vs)++instance ReadVariant '[] where+    readVariant = return unsafeEmptyVariant++instance (ShowLabel l, Read v, ReadVariant vs,+          HOccursNot (Label l) (LabelsOf vs))+    => ReadVariant (Tagged l v ': vs) where+    readVariant = do+      mlv <- optional lv+      case mlv of+        Nothing -> do+          rest <- readVariant+          return (l .=. mlv .*. rest)+        Just e -> do+          return (mkVariant l e p)++      where+        lv = do+            _ <- string (showLabel l)+            _ <- string "="+            readS_to_P reads++        l = Label :: Label l++        p = Proxy :: Proxy (Tagged l v ': vs)+++-- * Data+instance (Typeable (Variant v), GfoldlVariant v v,+          GunfoldVariant v v,+          VariantConstrs v)+        => Data (Variant v) where+    gfoldl = gfoldlVariant+    gunfold k z c = gunfoldVariant (\con -> k (z con)) (Proxy :: Proxy v) (constrIndex c - 1)+    toConstr v@(Variant n _) = case drop n (variantConstrs (dataTypeOf v) v) of+        c : _ -> c+        _ -> error "Data.HList.Variant.toConstr impossible"+    dataTypeOf x = let self = mkDataType (show (typeOf x)) (variantConstrs self x)+          in self++class VariantConstrs (xs :: [*]) where+  variantConstrs :: DataType -> proxy xs -> [Constr]++instance VariantConstrs '[] where+  variantConstrs _ _ = []++instance (ShowLabel l, VariantConstrs xs) => VariantConstrs (Tagged l e ': xs) where+  variantConstrs dt _ = mkConstr dt (showLabel (Label :: Label l)) [] Prefix :+        variantConstrs dt (Proxy :: Proxy xs)+++++{- | [@implementation of gunfold for Variant@]++In ghci++> :set -ddump-deriv -XDeriveDataTypeable+> data X a b c = A a | B b | C c deriving (Data,Typeable)++shows that gunfold is defined something like++> gunfold k z c = case constrIndex c of+>       1 -> k (z Ghci1.A)+>       2 -> k (z Ghci1.B)+>       _ -> k (z Ghci1.C)++If we instead had++> type X a b c = Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]++Then we could write:++> gunfold1 :: (forall b r. Data b => (b -> r) -> c r)+>          -> Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c]+> gunfold1 f c = case constrIndex c of+>       1 -> f mkA+>       2 -> f mkB+>       _ -> f mkC+>   where mkA a = mkVariant (Label :: Label "A") (a :: a) v+>         mkB b = mkVariant (Label :: Label "B") (b :: b) v+>         mkC c = mkVariant (Label :: Label "C") (c :: c) v+>         v = Proxy :: Proxy [Tagged "A" a, Tagged "B" b, Tagged "C" c]++where @f = k.z@+++-}+class GunfoldVariant (es :: [*]) v where+    gunfoldVariant ::+        (forall b. Data b => (b -> Variant v) -> c (Variant v))+          -- ^ @f = k . z@+        -> Proxy es+        -> Int+        -> c (Variant v)++instance (MkVariant l e v, Data e) => GunfoldVariant '[Tagged l e] v where+    gunfoldVariant f _ _ = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy)++instance (MkVariant l e v, Data e,+        GunfoldVariant (b ': bs) v) => GunfoldVariant (Tagged l e ': b ': bs)  v where+    gunfoldVariant f _ 0 = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy)+    gunfoldVariant f _ n = gunfoldVariant f (Proxy :: Proxy (b ': bs)) (n-1)++++class GfoldlVariant xs xs' where+  -- | the same as 'gfoldl', except the variant that is returned can have more+  -- possible values (needed to actually implement gfoldl).+  gfoldlVariant ::+     (forall d b. Data d => c (d -> b) -> d -> c b)+     -> (forall g. g -> c g) -> Variant xs -> c (Variant xs')++instance (a ~ Tagged l v, MkVariant l v r, Data v,+          GfoldlVariant (b ': c) r)+      => GfoldlVariant (a ': b ': c) r where+  gfoldlVariant k z xxs = case splitVariant1 xxs of+      Right xs -> gfoldlVariant k z xs+      -- If the c@type variable in 'gfoldl' had a Functor constraint,+      -- this case could be extendVariant `fmap` gfoldl k z xs,+      -- and then 'GfoldlVariant' would be unnecessary+      Left x ->+            let mkV e = mkVariant (Label :: Label l) e Proxy+            in z mkV `k` x++instance (Unvariant '[a] v, a ~ Tagged l v, Data v,+          MkVariant l v b) => GfoldlVariant '[a] b where+    gfoldlVariant k z xxs = z mkV `k` unvariant xxs+        where mkV e = mkVariant (Label :: Label l) e Proxy++++-- --------------------------------------------------------------------------+-- * Map+-- | Apply a function to all possible elements of the variant+newtype HMapV f = HMapV f++-- | shortcut for @applyAB . HMapV@. 'hMap' is more general+hMapV f v = applyAB (HMapV f) v++-- | @hMapOutV f = unvariant . hMapV f@, except an ambiguous type+-- variable is resolved by 'HMapOutV_gety'+hMapOutV :: forall x y z f. (SameLength x y,+      HMapAux Variant (HFmap f) x y,+      Unvariant y z,+      HMapOutV_gety x z ~ y+  ) => f -> Variant x -> z+hMapOutV f v = unvariant (hMapV f v :: Variant y)+++-- | resolves an ambiguous type in 'hMapOutV'+type family HMapOutV_gety (x :: [*]) (z :: *) :: [*]+type instance HMapOutV_gety (Tagged s x ': xs) z = Tagged s z ': HMapOutV_gety xs z+type instance HMapOutV_gety '[] z = '[]+++-- | apply a function to all values that could be in the variant.+instance (vx ~ Variant x,+          vy ~ Variant y,+          HMapAux Variant (HFmap f) x y,+          SameLength x y)+     => ApplyAB (HMapV f) vx vy where+    applyAB (HMapV f) x = hMapAux (HFmap f) x++instance (ApplyAB f te te') => HMapAux Variant f '[te] '[te'] where+    hMapAux f v = case splitVariant1' v of+        Left te -> unsafeMkVariant 0 (applyAB f te :: te')+        Right _ -> error "HMapVAux: variant invariant broken"++instance (ApplyAB f te te',+          HMapCxt Variant f (l ': ls) (l' ': ls'))+    => HMapAux Variant f (te ': l ': ls) (te' ': l' ': ls') where+      hMapAux f v = case splitVariant1' v of+          Left te -> unsafeMkVariant 0 (applyAB f te :: te')+          Right es -> extendVariant (hMapAux f es)++-- --------------------------------------------------------------------------+-- * HUpdateAtLabel instance++{- |++> hUpdateAtLabel x e' (mkVariant x e proxy) == mkVariant x e' proxy+> hUpdateAtLabel y e' (mkVariant x e proxy) == mkVariant x e  proxy++-}+instance+   (HUpdateVariantAtLabelCxt l e v v' n _e) =>+    HUpdateAtLabel Variant l e v v' where+    hUpdateAtLabel l e v = case hLookupByLabel l v of+          Just _e -> mkVariant l e (Proxy :: Proxy v')+          Nothing -> unsafeCastVariant v++type HUpdateVariantAtLabelCxt l e v v' n _e =+   (HFindLabel l v n,+    HFindLabel l v' n,+    HUpdateAtHNatR n (Tagged l e) v ~ v',+    HasField l (Variant v) (Maybe _e),+    HasField l (Record v') e,+    MkVariant l e v')+++-- --------------------------------------------------------------------------+-- * HExtend instance+{- | Extension for Variants prefers the first value++> (l .=. Nothing) .*. v = v+> (l .=. Just e)  .*. _ = mkVariant l e Proxy++-}+instance (le ~ Tagged l (Maybe e), HOccursNot (Label l) (LabelsOf v)) =>+    HExtend le (Variant v) where+    type HExtendR le (Variant v) = Variant (UnMaybe le ': v)+    Tagged (Just e) .*. _ = unsafeMkVariant 0 e+    Tagged Nothing .*. (Variant n e) = Variant (n+1) e++type family UnMaybe le+type instance UnMaybe (Tagged l (Maybe e)) = Tagged l e++-- | used for 'HExtend' 'TIP'+type instance UnMaybe (Maybe e) = e+++-- --------------------------------------------------------------------------+-- * Conversion to an untagged value+class HAllEqVal (x :: [*]) (b :: Bool) | x -> b+instance HAllEqVal '[] True+instance HAllEqVal '[x] True+instance (HEq a a' b,+          HAllEqVal (Tagged t a' ': xs) b2,+          HAnd b b2 ~ b3) =>+  HAllEqVal (Tagged s a ': Tagged t a' ': xs) b3+++class HAllEqVal' (x :: [*])+instance HAllEqVal' '[]+instance HAllEqVal' '[x]+instance (HAllEqVal' (ta ': xs),+          a' ~ a,+          ta ~ Tagged t a,+          ta' ~ Tagged t' a')+  => HAllEqVal' (ta' ': ta ': xs)+++{- | Similar to 'unvariant', except type variables in @v@+will be made equal to @e@ if possible. That allows the type+of @Nothing@ to be inferred as @Maybe Char@.++>>> unvariant' $ x .=. Nothing .*. mkVariant1 y 'y'+'y'++However, this difference leads to more local error messages+(@Couldn't match type ‘()’ with ‘Char’@), rather than the following+with @unvariant@:++> Fail+>    '("Variant",+>      '[Tagged "left" Char, Tagged "right" ()],+>      "must have all values equal to ",+>      e))++-}+class Unvariant' v e | v -> e where+    unvariant' :: Variant v -> e++instance (HAllEqVal' (Tagged () e ': v), Unvariant v e) =>+    Unvariant' v e where+  unvariant' = unvariant++{- | Convert a Variant which has all possibilities having the same type+into a value of that type. Analogous to @either id id@.++See also 'unvariant'' -}+class Unvariant v e | v -> e where+    unvariant :: Variant v -> e++instance (Unvariant1 b v e,+          HAllEqVal v b,+          HAllEqVal (Tagged () e ': v) b)+    => Unvariant v e where+      unvariant = unvariant1 (Proxy :: Proxy b)+++class Unvariant1 b v e | b v -> e where+    unvariant1 :: Proxy b -> Variant v -> e++instance (v ~ Tagged t1 e)+    => Unvariant1 True (v ': vs) e where+    unvariant1 _ = unsafeUnVariant++data UnvariantTypeMismatch (vs :: [*])++instance Fail (UnvariantTypeMismatch (v ': vs))+      => Unvariant1 False (v ': vs) (UnvariantTypeMismatch (v ': vs)) where+    unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances"++instance Fail "Unvariant applied to empty variant"+      => Unvariant1 b '[] (Proxy "Unvariant applied to empty variant") where+    unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances"++{- | @Lens (Variant s) (Variant t) a b@++Analogue of @Control.Lens.chosen :: Lens (Either a a) (Either b b) a b@+-}+unvarianted :: (Unvariant' s a,+                Unvariant' t b,+                SameLabels s t, -- extra constraints to reduce ambiguity+                SameLength s t,+                Functor f) =>+    (a -> f b) -> Variant s -> f (Variant t)+unvarianted f v@(Variant n _) = fmap (\e' -> unsafeMkVariant n e')+                                      (f (unvariant' v))++-- | @Lens' (Variant s) a@+--+-- where we might have @s ~ '[Tagged t1 a, Tagged t2 a]@+unvarianted' x = simple (unvarianted x)++-- * Zip++{- | Applies to variants that have the same labels+in the same order. A generalization of++> zipEither :: Either a b -> Either a b -> Maybe (Either (a,a) (b,b))+> zipEither (Left a) (Left a') = Just (Left (a,a'))+> zipEither (Right a) (Right a') = Just (Right (a,a'))+> zipEither _ _ = Nothing++see 'HZip' for zipping other collections++-}+class ZipVariant x y xy | x y -> xy, xy -> x y where+    zipVariant :: Variant x -> Variant y -> Maybe (Variant xy)++instance ZipVariant '[] '[] '[] where+    zipVariant _ _ = Nothing++instance (tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y),+          ZipVariant xs ys zs,+          MkVariant t (x,y) (txy ': zs))+  => ZipVariant (tx ': xs) (ty ': ys) (txy ': zs) where+    zipVariant x y = case (splitVariant1 x, splitVariant1 y) of+        (Left x', Left y') -> Just (mkVariant (Label :: Label t) (x',y') Proxy)+        (Right x', Right y') -> extendVariant <$> zipVariant x' y'+        _ -> Nothing+++instance (HUnzip Variant (x2 ': xs) (y2 ': ys) (xy2 ': xys),+          SameLength xs ys,+          SameLength ys xys,+          tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y))+      => HUnzip Variant (tx ': x2 ': xs) (ty ': y2 ': ys) (txy ': xy2 ': xys) where+    hUnzip xy = case splitVariant1 xy of+      Left (x,y) -> (mkVariant (Label :: Label t) x Proxy,+                     mkVariant (Label :: Label t) y Proxy)+      Right xy' | (x,y) <- hUnzip xy' ->+                    (extendVariant x,+                     extendVariant y)++instance (Unvariant '[txy] txy,+          tx ~ Tagged t x,+          ty ~ Tagged t y,+          txy ~ Tagged t (x,y))+      => HUnzip Variant '[tx] '[ty] '[txy] where+    hUnzip xy | Tagged (x,y) <- unvariant xy =+        (mkVariant1 Label x, mkVariant1 Label y)+++-- ** with a record++{- | Apply a record of functions to a variant of values.+The functions are selected based on those having the same+label as the value.++-}+class (SameLength v v',+       SameLabels v v')  => ZipVR fs v v' | fs v -> v' where+    -- | 'zipVR' is probably a better choice in most+    -- situations, since it requires that @fs@ has one function for every+    -- element of @v@+    zipVR_ :: Record fs -> Variant v -> Variant v'++instance (lv ~ Tagged l v,+          lv' ~ Tagged l v',+          HMemberM (Label l) (LabelsOf fs) b,+          HasFieldM l (Record fs) f,+          DemoteMaybe (v -> v) f ~ (v -> v'),+          MkVariant l v' (lv' ': rs),+          ZipVR fs vs rs) =>+          ZipVR fs (lv ': vs) (lv' ': rs) where+    zipVR_ r lvs = case splitVariant1 lvs of+                  Left v | v' <- hLookupByLabelM l r (id :: v -> v) v -> mkVariant l v' Proxy+                  Right vs -> extendVariant $ zipVR_ r vs+      where l = Label :: Label l+++instance ZipVR fs '[] '[] where+    zipVR_ _ x = x++{- |++>>> let xy = x .*. y .*. emptyProxy+>>> let p = Proxy `asLabelsOf` xy+>>> let vs = [ mkVariant x 1.0 p, mkVariant y () p ]+++>>> zipVR (hBuild (+1) id) `map` vs+[V{x=2.0},V{y=()}]+++-}+zipVR :: (SameLabels fs v, SameLength fs v, ZipVR fs v v',+          ZipVRCxt fs v v')+    => Record fs -> Variant v -> Variant v'+zipVR = zipVR_+++{- | Lets 'zipVR' act as if @'ZipVR' fs v v'@ had an FD @v v' -> fs@++> ZipVRCxt [Tagged s f,  Tagged t g]+>          [Tagged s fx, Tagged t gx]+>          [Tagged s fy, Tagged t gy]+>   = (f ~ (fx -> fy), g ~ (gx -> gy))++-}+type family ZipVRCxt (fs :: [*]) (xs :: [*]) (ys :: [*]) :: Constraint++type instance ZipVRCxt (Tagged s f ': fs) (Tagged s x ': xs) (Tagged s y ': ys) =+        (f ~ (x -> y), ZipVRCxt fs xs ys)+type instance ZipVRCxt '[] '[] '[] = ()++-- * Eq+instance Eq (Variant '[]) where+  _ == _ = True++instance (Eq (Variant xs), Eq x) => Eq (Variant (x ': xs)) where+  v == v' = case (splitVariant1' v, splitVariant1' v') of+    (Left l, Left r) -> l == r+    (Right l, Right r) -> l == r+    _ -> False++-- ** Alternative Eq+-- | implemented like @and (zipWith (==) xs ys)@. Behaves the same as the Eq instances for 'Variant'+eqVariant v v' = maybe False (hMapOutV UncurryEq) $ zipVariant v v'++data UncurryEq = UncurryEq++instance (ee ~ (e,e), Eq e, bool ~ Bool) =>+    ApplyAB UncurryEq ee bool where+      applyAB _ (e,e') = e == e'++-- * Ord+instance Ord (Variant '[]) where+  compare _ _ = EQ++instance (Ord x, Ord (Variant xs)) => Ord (Variant (x ': xs)) where+  compare a b = compare (splitVariant1' a) (splitVariant1' b)++-- * Bounded+instance (Bounded x, Bounded z,+          HRevAppR (Tagged s x ': xs) '[] ~ (Tagged t z ': sx),+          MkVariant t z (Tagged s x ': xs))+        => Bounded (Variant (Tagged s x ': xs)) where+  minBound = mkVariant (Label :: Label s) (minBound :: x) Proxy+  maxBound = mkVariant (Label :: Label t) (maxBound :: z) Proxy++-- * Enum+{- |++>>> let t = minBound :: Variant '[Tagged "x" Bool, Tagged "y" Bool]+>>> [t .. maxBound]+[V{x=False},V{x=True},V{y=False},V{y=True}]+++[@Odd behavior@]+There are some arguments that this instance should not exist.++The last type in the Variant does not need to be Bounded. This+means that 'enumFrom' behaves a bit unexpectedly:++>>> [False .. ]+[False,True]++>>> [t .. ]+[V{x=False},V{x=True},V{y=False},V{y=True},V{y=*** Exception: Prelude.Enum.Bool.toEnum: bad argument++This is a \"feature\" because it allows an @Enum (Variant '[Tagged \"a\" Bool, Tagged \"n\" 'Integer'])@++Another difficult choice is that the lower bound is @fromEnum 0@ rather than @minBound@:++>>> take 5 [ minBound :: Variant '[Tagged "b" Bool, Tagged "i" Int] .. ]+[V{b=False},V{b=True},V{i=0},V{i=1},V{i=2}]++-}+instance (Enum x, Bounded x, Enum (Variant (y ': z))) => Enum (Variant (Tagged s x ': y ': z)) where+  fromEnum v = case splitVariant1 v of+    Left x -> fromEnum x+    Right yz -> 1 + fromEnum (maxBound :: Tagged s x) + fromEnum yz++  toEnum n+      | m >= n = mkVariant (Label :: Label s) (toEnum n) Proxy+      | otherwise = extendVariant $ toEnum (n - m - 1)+    where m = fromEnum (maxBound :: Tagged s x)++{- |++While the instances could be written Enum (Variant '[])+Eq/Ord which cannot produce values, so they have instances for+empty variants ('unsafeEmptyVariant'). Enum can produce values,+so it is better that @fromEnum 0 :: Variant '[]@ fails with No instance for+@Enum (Variant '[])@ than producing an invalid variant.++-}+instance Enum x => Enum (Variant '[Tagged s x]) where+  fromEnum v = case splitVariant1 v of+    Left x -> fromEnum x+    _ -> error "Data.HList.Variant fromEnum impossible"+  toEnum n = mkVariant (Label :: Label s) (toEnum n) Proxy++-- * Ix (TODO)++-- * Semigroup+instance (Unvariant '[Tagged t x] x, Semigroup x) => Semigroup (Variant '[Tagged t x]) where+    a <> b = case (unvariant a, unvariant b) of+                    (l, r) -> mkVariant (Label :: Label t) (l <> r) Proxy++instance (Semigroup x, Semigroup (Variant (a ': b))) => Semigroup (Variant (Tagged t x ': a ': b)) where+    a <> b = case (splitVariant1 a, splitVariant1 b) of+                    (Left l, Left r) -> mkVariant (Label :: Label t) (l <> r) Proxy+                    (Left l, _) -> mkVariant (Label :: Label t) l Proxy+                    (_, Left r) -> mkVariant (Label :: Label t) r Proxy+                    (Right l, Right r) -> extendVariant $ l <> r++-- * Monoid+instance (Unvariant '[Tagged t x] x, Monoid x) => Monoid (Variant '[Tagged t x]) where+    mempty = mkVariant (Label :: Label t) mempty Proxy+#if __GLASGOW_HASKELL__ <= 906+    mappend a b = case (unvariant a, unvariant b) of+                    (l, r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+#endif+++instance (Monoid x, Monoid (Variant (a ': b))) => Monoid (Variant (Tagged t x ': a ': b)) where+    mempty = extendVariant mempty+#if __GLASGOW_HASKELL__ <= 906+    mappend a b = case (splitVariant1 a, splitVariant1 b) of+                    (Left l, Left r) -> mkVariant (Label :: Label t) (mappend l r) Proxy+                    (Left l, _) -> mkVariant (Label :: Label t) l Proxy+                    (_, Left r) -> mkVariant (Label :: Label t) r Proxy+                    (Right l, Right r) -> extendVariant $ mappend l r+#endif++-- * Projection++{- | convert a variant with more fields into one with fewer (or the same)+fields.+++>>> let ty = Proxy :: Proxy [Tagged "left" Int, Tagged "right" Int]+>>> let l = mkVariant _left 1 ty+>>> let r = mkVariant _right 2 ty+++>>> map projectVariant [l, r] :: [Maybe (Variant '[Tagged "left" Int])]+[Just V{left=1},Nothing]+++@'rearrangeVariant' = 'fromJust' . 'projectVariant'@ is one implementation+of 'rearrangeVariant', since the result can have the same fields with+a different order:++>>> let yt = Proxy :: Proxy [Tagged "right" Int, Tagged "left" Int]++>>> map projectVariant [l, r] `asTypeOf` [Just (mkVariant _left 0 yt)]+[Just V{left=1},Just V{right=2}]+++-}+class ProjectVariant x y where+    projectVariant :: Variant x -> Maybe (Variant y)++instance (ProjectVariant x ys,+          HasField t (Variant x) (Maybe y),+          HOccursNot (Label t) (LabelsOf ys),+          ty ~ Tagged t y)+  => ProjectVariant x (ty ': ys) where+    projectVariant x = y `mplus` ys+      where t = Label :: Label t+            y = (\v -> mkVariant t v Proxy) <$> x .!. t+            ys = (mty  .*.) <$> (projectVariant x :: Maybe (Variant ys))+            mty = Tagged Nothing :: Tagged t (Maybe y)++instance ProjectVariant x '[] where+    projectVariant _ = Nothing++++{- | @projectExtendVariant = fmap 'extendVariant' . 'projectVariant'@++where intermediate variant is as large as possible. Used to implement+"Data.HList.Labelable".'projected'++Note that:++>>> let r = projectExtendVariant (mkVariant1 Label 1 :: Variant '[Tagged "x" Int])+>>> r :: Maybe (Variant '[Tagged "x" Integer])+Nothing++-}+class HAllTaggedLV y => ProjectExtendVariant x y where+    projectExtendVariant :: Variant x -> Maybe (Variant y)++instance HAllTaggedLV y => ProjectExtendVariant '[] y where+    projectExtendVariant _ = Nothing++instance (lv ~ Tagged l v,+          HMemberM lv y inY,+          ProjectExtendVariant' inY lv y,+          ProjectExtendVariant xs y+      ) => ProjectExtendVariant (lv ': xs) y where+  projectExtendVariant v = case splitVariant1' v of+      Left lv -> projectExtendVariant' (Proxy :: Proxy inY) lv+      Right v' -> projectExtendVariant v'+++class ProjectExtendVariant' (inY :: Maybe [*]) lv (y :: [*]) where+    projectExtendVariant' :: Proxy inY -> lv -> Maybe (Variant y)++instance ProjectExtendVariant' Nothing lv y where+    projectExtendVariant' _ _ = Nothing++instance (MkVariant l v y, lv ~ Tagged l v) => ProjectExtendVariant' (Just t) lv y where+    projectExtendVariant' _ (Tagged v) = Just (mkVariant (Label :: Label l) v Proxy)++++class (ProjectVariant x yin,+       ProjectVariant x yout) => SplitVariant x yin yout where+    splitVariant :: Variant x -> Either (Variant yin) (Variant yout)++instance+   (-- implementation+    ProjectVariant x yin,+    ProjectVariant x yout,++    -- constraints to ensure exactly one of+    -- the uses of projectVariant gives a Just+    H2ProjectByLabels (LabelsOf yin) x xi xo,+    HRearrange (LabelsOf yin) xi yin,+    HRearrange (LabelsOf yout) xo yout,++    HLeftUnion xi xo xixo,+    HRearrange (LabelsOf x) xixo x,++    -- probably redundant+    HAllTaggedLV x, HAllTaggedLV yin, HAllTaggedLV yout) =>+  SplitVariant x yin yout where+  splitVariant x = case (projectVariant x, projectVariant x) of+   (Nothing, Just yout) -> Right yout+   (Just yin, Nothing) -> Left yin+   _ -> error "Data.HList.Variant:splitVariant impossible"++-- | @projectVariant . extendsVariant = Just@ (when the types match up)+--+-- 'extendVariant' is a special case+class (HAllTaggedLV y, HAllTaggedLV x) => ExtendsVariant x y where+    extendsVariant :: Variant x -> Variant y++instance (MkVariant l e y, le ~ Tagged l e,+          ExtendsVariant (b ': bs) y) => ExtendsVariant (le ': b ': bs) y where+    extendsVariant v = case splitVariant1 v of+        Left e -> mkVariant (Label :: Label l) (e :: e) Proxy+        Right vs -> extendsVariant vs++instance (HAllTaggedLV x, Unvariant '[le] e, MkVariant l e x,+          le ~ Tagged l e) => ExtendsVariant '[le] x where+    extendsVariant v = mkVariant (Label :: Label l) (unvariant v) Proxy+++-- | @rearrangeVariant@ is a specialization of 'extendsVariant' whose+-- result is always . see also 'rearranged'+rearrangeVariant :: (SameLength v v', ExtendsVariant v v')+      => Variant v -> Variant v'+rearrangeVariant v = extendsVariant v++instance (SameLength s a, ExtendsVariant s a,+          SameLength b t, ExtendsVariant b t) => Rearranged Variant s t a b+  where+    rearranged = iso rearrangeVariant rearrangeVariant++-- | @Prism (Record tma) (Record tmb) (Variant ta) (Variant tb)@+--+-- see 'hMaybied''+hMaybied x = prism variantToHMaybied+    (\s -> case hMaybiedToVariants s of+          [a] -> Right a+          _ -> Left (hMapR HCastF s))+    x+++data HCastF = HCastF++instance (mx ~ Maybe x,+          my ~ Maybe y,+          HCast y x) =>+  ApplyAB HCastF mx my where+    applyAB _ x = hCast =<< x++++{- | @Prism' (Record tma) (Variant ta)@++where @tma@ and @tmb@ are lists like++> tma ~ '[Tagged x (Maybe a), Tagged y (Maybe b)]+> ta  ~ '[Tagged x        a , Tagged y        b ]++If one element of the record is Just, the Variant will+contain that element. Otherwise, the prism fails.++[@Note@]++The types work out to define a prism:++@l = 'prism'' 'variantToHMaybied' ('listToMaybe' . 'hMaybiedToVariants')@++but the law: @s^?l ≡ Just a ==> l # a ≡ s@ is not followed,+because we could have:++@+  s, s2 :: Record '[Tagged "x" (Maybe Int), Tagged "y" (Maybe Char)]+  s = hBuild (Just 1) (Just '2')+  s2 = hBuild (Just 1) Nothing++  v :: Variant '[Tagged "x" Int, Tagged "y" Char]+  v = mkVariant (Label :: Label "x") 1 Proxy+@++So that @s^?l == Just v@. But @l#v == s2 /= s@, while the law+requires @l#v == s@. hMaybied avoids this problem by only+producing a value when there is only one present.++-}+hMaybied' x = simple (hMaybied (simple x))++class VariantToHMaybied v r | v -> r, r -> v where+    variantToHMaybied :: Variant v -> Record r++instance VariantToHMaybied '[] '[] where+    variantToHMaybied _ = emptyRecord++instance (VariantToHMaybied v r,+          HReplicateF nr ConstTaggedNothing () r,++          tx ~ Tagged t x,+          tmx ~ Tagged t (Maybe x))+    => VariantToHMaybied (tx ': v) (tmx ': r) where+      variantToHMaybied v = case splitVariant1 v of+            Left x -> Record+                $ HCons (Tagged (Just x))+                $ hReplicateF Proxy ConstTaggedNothing ()+            Right rest ->+                case variantToHMaybied rest of+                  Record a -> Record $ (Tagged Nothing :: Tagged t (Maybe x)) `HCons` a+          -- don't use (.*.) because we have (LabelsOf v ~ LabelsOf r), so+          -- the duplicate check (HRLabelSet) implied by (.*.) is redundant++data ConstTaggedNothing = ConstTaggedNothing+instance (y ~ Tagged t (Maybe e)) => ApplyAB ConstTaggedNothing x y where+    applyAB _ _ = Tagged Nothing++-- | Every element of the record that is Just becomes one element+-- in the resulting list. See 'hMaybied'' example types that @r@+-- and @v@ can take.+hMaybiedToVariants ::+  (HFoldr HMaybiedToVariantFs [Variant '[]] r [Variant v], -- impl+   VariantToHMaybied v r -- evidence for typechecking+  ) => Record r -> [Variant v]+hMaybiedToVariants (Record r) = hFoldr HMaybiedToVariantFs ([] :: [Variant '[]]) r++data HMaybiedToVariantFs = HMaybiedToVariantFs++instance (x ~ (Tagged t (Maybe e), [Variant v]),+          y ~ [Variant (Tagged t e ': v)],+          MkVariant t e (Tagged t e ': v))+        => ApplyAB HMaybiedToVariantFs x y where++  applyAB _ (Tagged me, v) = case me of+    Just e -> mkVariant (Label :: Label t) e Proxy : map extendVariant v+    _ -> fmap extendVariant v
+ hlist/LensDefs.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+-- | parts of lens that would be imported if we depended on it+module LensDefs+  (module LensDefs,+   module Control.Applicative,+   Choice,+   Profunctor,+   Coercible)+   where++import Data.Profunctor+import Data.Profunctor.Unsafe+import Control.Applicative+import Control.Monad.Identity++import Unsafe.Coerce+#if __GLASGOW_HASKELL__ > 707+import GHC.Exts(Coercible)+#else+import GHC.Exts(Constraint)+-- | for ghc-7.6 we don't have coercible+type Coercible a b = (() :: Constraint)+#endif+++type Equality' s a = forall p (f :: * -> *). a `p` f a -> s `p` f s++{- | if we write @f' = simple . f@, then the inferred type is++> f' :: (s ~ t, _) => Lens s t a b++which normally will let ghc figure out (a~b). However with the+types that come up in HList this can only be figure out with+concrete types, so we use isSimple instead which also specifies+(a~b).++-}+isSimple :: optic ~ (p a (f a) -> p s (f s)) => optic -> optic+isSimple = id+-- alternatively: isSimple x = simple . x . simple++simple :: Equality' a a+simple = id++-- Used by doctests (which should probably just import Control.Lens...)+infixl 1 &+x & f = f x++infixr 4 %~+l %~ f = \t -> runIdentity $ l (rmap Identity f) t++iso :: (Profunctor p, Functor f)+    => (s -> a) -> (b -> t)+    -> p a (f b) -> p s (f t)+iso sa bt = dimap sa (fmap bt)++-- | iso, except assumes that the functions supplied could+-- be 'Data.Coerce.coerce'+isoNewtype :: (Profunctor p, Functor f,+               Coercible b t, -- Coercible (f b) (f t) -- is really needed but that complicates types later on (since f is forall'd)+               Coercible a s)+    => (s -> a) -> (b -> t)+    -> p a (f b) -> p s (f t)+isoNewtype sa _bt x = coerceBT x .# sa+  where coerceBT :: p a (f b) -> p a (f t)+        coerceBT = unsafeCoerce++prism :: (b -> t) -> (s -> Either t a)+    -> (forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t))+prism bt seta = dimap seta (either pure (fmap bt)) . right'++prism' :: (a -> s) -> (s -> Maybe a)+    -> (forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s))+prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))
+ multi-containers/Data/Multimap/Table.hs view
@@ -0,0 +1,126 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Multimap.Table+-- Maintainer  :  Ziyang Liu <free@cofree.io>+--+-- The @'Table' r c a@ type represents a finite two-dimensional table+-- that associates a pair of keys (a row key of type @r@ and+-- a column key of type @c@) with a value of type @a@.+--+-- The implementation is backed by two maps: a @'Map' r ('Map' c) a@, and+-- a @'Map' c ('Map' r) a@, called "row map" and "column map", respectively.+--+-- It is worth noting that all functions that traverse a table, such as+-- 'foldl', 'foldr', 'foldMap' and 'traverse', are row-oriented, i.e.,+-- they traverse the table row by row. To traverse a table column+-- by column, 'transpose' the table first.+--+-- In the following Big-O notations, unless otherwise noted, /n/ denotes+-- the size of the table (i.e., the total number of values for all+-- row and column keys), /r/ denotes the number of row keys that has at+-- least one value, /c/ denotes the number of column keys that has at+-- least one value, and /k = max r c/.+module Data.Multimap.Table (+  Table++  -- * Construction+  , empty+  , singleton+  , fromRowMap+  , fromColumnMap+  , transpose++  -- ** From Unordered Lists+  , fromList++  -- * Deletion\/Update+  , insert+  , delete+  , deleteRow+  , deleteColumn+  , adjust+  , adjustWithKeys+  , update+  , updateWithKeys+  , alter+  , alterWithKeys++  -- * Query+  -- ** Lookup+  , lookup+  , (!?)+  , (!)+  , hasCell+  , hasRow+  , hasColumn++  -- ** Size+  , null+  , notNull+  , size++  -- * Combine+  -- ** Union+  , union+  , unionWith+  , unionWithKeys+  , unions+  , unionsWith+  , unionsWithKeys++  -- ** Difference+  , difference++  -- * Traversal+  -- ** Map+  , map+  , mapWithKeys+  , traverseWithKeys+  , traverseMaybeWithKeys++  -- ** Folds+  , foldr+  , foldl+  , foldrWithKeys+  , foldlWithKeys+  , foldMapWithKeys++  -- ** Strict Folds+  , foldr'+  , foldl'+  , foldrWithKeys'+  , foldlWithKeys'++  -- * Conversion+  , row+  , column+  , rowMap+  , columnMap+  , rowKeys+  , columnKeys+  , rowKeysSet+  , columnKeysSet++  -- ** Lists+  , toList++  -- ** Ordered lists+  , toRowAscList+  , toColumnAscList+  , toRowDescList+  , toColumnDescList++  -- * Filter+  , filter+  , filterRow+  , filterColumn+  , filterWithKeys++  , mapMaybe+  , mapMaybeWithKeys+  , mapEither+  , mapEitherWithKeys+  ) where++import Data.Multimap.Table.Internal+import Prelude hiding (Foldable(..), filter, lookup, map)
+ multi-containers/Data/Multimap/Table/Internal.hs view
@@ -0,0 +1,813 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Multimap.Table.Internal+-- Maintainer  :  Ziyang Liu <free@cofree.io>+--+module Data.Multimap.Table.Internal (+  Table (..)+  , Size++  -- * Construction+  , empty+  , singleton+  , fromRowMap+  , fromColumnMap+  , transpose++  -- ** From Unordered Lists+  , fromList++  -- * Deletion\/Update+  , insert+  , delete+  , deleteRow+  , deleteColumn+  , adjust+  , adjustWithKeys+  , update+  , updateWithKeys+  , alter+  , alterWithKeys++  -- * Query+  -- ** Lookup+  , lookup+  , (!?)+  , (!)+  , hasCell+  , hasRow+  , hasColumn++  -- ** Size+  , null+  , notNull+  , size++  -- * Combine+  -- ** Union+  , union+  , unionWith+  , unionWithKeys+  , unions+  , unionsWith+  , unionsWithKeys++  -- ** Difference+  , difference++  -- * Traversal+  -- ** Map+  , map+  , mapWithKeys+  , traverseWithKeys+  , traverseMaybeWithKeys++  -- ** Folds+  , foldr+  , foldl+  , foldrWithKeys+  , foldlWithKeys+  , foldMapWithKeys++  -- ** Strict Folds+  , foldr'+  , foldl'+  , foldrWithKeys'+  , foldlWithKeys'++  -- * Conversion+  , row+  , column+  , rowMap+  , columnMap+  , rowKeys+  , columnKeys+  , rowKeysSet+  , columnKeysSet++  -- ** Lists+  , toList++  -- ** Ordered lists+  , toRowAscList+  , toColumnAscList+  , toRowDescList+  , toColumnDescList++  -- * Filter+  , filter+  , filterRow+  , filterColumn+  , filterWithKeys++  , mapMaybe+  , mapMaybeWithKeys+  , mapEither+  , mapEitherWithKeys+  ) where++import           Control.Arrow ((&&&))+import           Data.Data (Data)+import           Data.Foldable (Foldable)+import qualified Data.Foldable as Foldable+import           Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import           Data.Set (Set)++import Prelude hiding (Foldable(..), filter, lookup, map)++infixl 9 !,!?++type Size = Int++newtype Table r c a = Table (Map r (Map c a), Map c (Map r a), Size)+  deriving (Eq, Ord, Data)++instance (Show r, Show c, Show a) => Show (Table r c a) where+  showsPrec d m = showParen (d > 10) $+    showString "fromList " . shows (toList m)++instance (Ord r, Ord c, Read r, Read c, Read a) => Read (Table r c a) where+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    pure (fromList xs,t)++instance Functor (Table r c) where+  fmap = map++instance Foldable.Foldable (Table r c) where+  foldMap = foldMapWithKeys . const . const+  {-# INLINE foldMap #-}++instance (Ord r, Ord c) => Traversable (Table r c) where+  traverse = traverseWithKeys . const . const+  {-# INLINE traverse #-}++instance (Ord r, Ord c) => Semigroup (Table r c a) where+  (<>) = union++instance (Ord r, Ord c) => Monoid (Table r c a) where+  mempty = empty+  mappend = (<>)++------------------------------------------------------------------------------++-- | /O(1)/. The empty table.+--+-- > size empty === 0+empty :: Table r c a+empty = Table (Map.empty, Map.empty, 0)++-- | /O(1)/. A table with a single element.+--+-- > singleton 1 'a' "a" === fromList [(1,'a',"a")]+-- > size (singleton 1 'a' "a") === 1+singleton :: r -> c -> a -> Table r c a+singleton r c a = Table (Map.singleton r (Map.singleton c a), Map.singleton c (Map.singleton r a), 1)++-- | Build a table from a list of key\/value pairs.+--+-- > fromList ([] :: [(Int, Char, String)]) === empty+fromList :: (Ord r, Ord c) => [(r, c, a)] -> Table r c a+fromList = Foldable.foldr (uncurry3 insert) empty++-- | Build a table from a row map.+--+-- > fromRowMap (Map.fromList [(1, Map.fromList [('a',"b"),('b',"c")]), (2, Map.fromList [('a',"d")])])+-- >   === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]+fromRowMap :: (Ord r, Ord c) => Map r (Map c a) -> Table r c a+fromRowMap m = Table (m', transpose' m', size' m')+  where m' = nonEmpty m++-- | Build a table from a column map.+--+-- > fromColumnMap (Map.fromList [(1, Map.fromList [('a',"b"),('b',"c")]), (2, Map.fromList [('a',"d")])])+-- >   === fromList [('a',1,"b"),('a',2,"d"),('b',1,"c")]+fromColumnMap :: (Ord r, Ord c) => Map c (Map r a) -> Table r c a+fromColumnMap m = Table (transpose' m', m', size' m')+  where m' = nonEmpty m++-- | Flip the row and column keys.+--+-- > transpose (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [('a',1,"b"),('a',2,"d"),('b',1,"c")]+transpose :: Table r c a -> Table c r a+transpose (Table (rm, cm, sz)) = Table (cm, rm, sz)++------------------------------------------------------------------------------++-- | /O(log k)/. Associate with value with the row key and the column key.+-- If the table already contains a value for those keys, the value is replaced.+--+-- > insert 1 'a' "a" empty === singleton 1 'a' "a"+-- > insert 1 'a' "a" (fromList [(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"d")]+-- > insert 1 'a' "a" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"d")]+insert :: (Ord r, Ord c) => r -> c -> a -> Table r c a -> Table r c a+insert r c a (Table (rm, cm, _)) = fromMaps' r c rm' cm'+  where+    rm' = Map.alter f r rm+    cm' = Map.alter g c cm+    f = Just . maybe (Map.singleton c a) (Map.insert c a)+    g = Just . maybe (Map.singleton r a) (Map.insert r a)++-- | /O(log k)/. Remove the value associated with the given keys.+--+-- > delete 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'b',"c"),(2,'a',"d")]+-- > delete 1 'a' (fromList [(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'b',"c"),(2,'a',"d")]+delete :: (Ord r, Ord c) => r -> c -> Table r c a -> Table r c a+delete r c (Table (rm, cm, _)) = fromMaps' r c rm' cm'+  where+    rm' = Map.adjust (Map.delete c) r rm+    cm' = Map.adjust (Map.delete r) c cm++-- | Remove an entire row.+--+-- > deleteRow 1 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 2 'a' "d"+-- > deleteRow 3 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]+deleteRow :: Ord r => r -> Table r c a -> Table r c a+deleteRow r (Table (rm, cm, _)) = Table (rm', cm', size' rm')+  where+    rm' = Map.delete r rm+    cm' = nonEmpty $ Map.map (Map.delete r) cm++-- | Remove an entire column.+--+-- > deleteColumn 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "c"+-- > deleteColumn 'z' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]+deleteColumn :: Ord c => c -> Table r c a -> Table r c a+deleteColumn c (Table (rm, cm, _)) = Table (rm', cm', size' cm')+  where+    rm' = nonEmpty $ Map.map (Map.delete c) rm+    cm' = Map.delete c cm++-- | /O(log k)/, assuming the function @a -> a@ takes /O(1)/.+-- Update the value at a specific row key and column key, if exists.+--+-- > adjust ("new " ++) 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"new b"),(1,'b',"c"),(2,'a',"d")]+adjust :: (Ord r, Ord c) => (a -> a) -> r -> c -> Table r c a -> Table r c a+adjust = adjustWithKeys . const . const++-- | /O(log k)/, assuming the function @r -> c -> a -> a@ takes /O(1)/.+-- Update the value at a specific row key and column key, if exists.+--+-- > adjustWithKeys (\r c x -> show r ++ ":" ++ show c ++ ":new " ++ x) 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")])+-- >   === fromList [(1,'a',"1:'a':new b"),(1,'b',"c"),(2,'a',"d")]+adjustWithKeys+  :: (Ord r, Ord c)+  => (r -> c -> a -> a) -> r -> c -> Table r c a -> Table r c a+adjustWithKeys f = updateWithKeys (\r c a -> Just (f r c a))++-- | /O(log k)/, assuming the function @a -> 'Maybe' a@ takes /O(1)/.+-- The expression (@'update' f r c table@) updates the value at the given+-- row and column keys, if exists. If @f@ returns 'Nothing', the value+-- associated with those keys, if exists is deleted.+--+-- > let f x = if x == "b" then Just "new b" else Nothing in do+-- >   update f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"new b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   update f 1 'a' (fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+update :: (Ord r, Ord c) => (a -> Maybe a) -> r -> c -> Table r c a -> Table r c a+update = updateWithKeys . const . const++-- | /O(log k)/, assuming the function @r -> c -> a -> 'Maybe' a@ takes /O(1)/.+-- The expression (@'updateWithKeys' f r c table@) updates the value at the given+-- row and column keys, if exists. If @f@ returns 'Nothing', the value+-- associated with those keys, if exists is deleted.+--+-- > let f r c x = if x == "b" then Just (show r ++ ":" ++ show c ++ ":new b") else Nothing in do+-- >   updateWithKeys f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"1:'a':new b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   updateWithKeys f 1 'a' (fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+updateWithKeys+  :: (Ord r, Ord c)+  => (r -> c -> a -> Maybe a) -> r -> c -> Table r c a -> Table r c a+updateWithKeys f = alterWithKeys (\r c -> (>>= f r c))++-- | /O(log k)/, assuming the function @'Maybe' a -> 'Maybe' a@ takes /O(1)/.+-- The expression (@'alter' f r c table@) alters the value at the given+-- row and column keys, if exists. It can be used to insert, delete+-- or update a value.+--+-- > let (f,g,h) = (const Nothing, const (Just "hello"), fmap ('z':)) in do+-- >   alter f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alter f 4 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alter f 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alter g 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"hello"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alter g 4 'e' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c"),(4,'e',"hello")]+-- >   alter h 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"zb"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alter h 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+alter :: (Ord r, Ord c) => (Maybe a -> Maybe a) -> r -> c -> Table r c a -> Table r c a+alter = alterWithKeys . const . const++-- | /O(log k)/, assuming the function @r -> c -> 'Maybe' a -> 'Maybe' a@ takes /O(1)/.+-- The expression (@'alterWithKeys' f r c table@) alters the value at the given+-- row and column keys, if exists. It can be used to insert, delete+-- or update a value.+--+-- > let (f,g) = (\_ _ _ -> Nothing, \r c -> fmap ((show r ++ ":" ++ show c ++ ":") ++)) in do+-- >   alterWithKeys f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alterWithKeys f 4 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alterWithKeys f 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alterWithKeys g 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"1:'a':b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+-- >   alterWithKeys g 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]+alterWithKeys+  :: (Ord r, Ord c)+  => (r -> c -> Maybe a -> Maybe a) -> r -> c -> Table r c a -> Table r c a+alterWithKeys f r c tbl@(Table (rm, cm, _))+  | Just a <- f r c (lookup r c tbl) =+      let rm' = Map.alter (Just . maybe (Map.singleton c a) (Map.insert c a)) r rm+          cm' = Map.alter (Just . maybe (Map.singleton r a) (Map.insert r a)) c cm+       in fromMaps' r c rm' cm'+  | otherwise = delete r c tbl++------------------------------------------------------------------------------++-- | /O(log k)/. Lookup the values at a row key and column key in the map.+lookup :: (Ord r, Ord c) => r -> c -> Table r c a -> Maybe a+lookup r c (Table (rm, _, _)) = Map.lookup r rm >>= Map.lookup c++-- | /O(log k)/. Lookup the values at a row key and column key in the map.+--+-- > fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")] !? (1,'a') === Just "b"+-- > fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")] !? (1,'c') === Nothing+(!?) :: (Ord r, Ord c) => Table r c a -> (r, c) -> Maybe a+(!?) = flip (uncurry lookup)++-- | /O(log k)/. Lookup the values at a row key and column key in the map.+-- Calls 'error' if the value does not exist.+--+-- > fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")] ! (1,'a') === "b"+(!) :: (Ord r, Ord c) => Table r c a -> (r, c) -> a+(!) tbl keys =+  Maybe.fromMaybe (error "Table.!: cell does not exist") (tbl !? keys)++-- | /O(log k)/. Is there a value associated with the given row and+-- column keys?+--+-- > hasCell (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (1,'a') === True+-- > hasCell (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (1,'c') === False+hasCell :: (Ord r, Ord c) => Table r c a -> (r, c) -> Bool+hasCell (Table (rm, _, _)) (r, c) =+  maybe False (Map.member c) (Map.lookup r rm)++-- | /O(log r)/. Is there a row with the given row key that has at least+--  one value?+--+-- > hasRow (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 1 === True+-- > hasRow (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 3 === False+hasRow :: Ord r => Table r c a -> r -> Bool+hasRow (Table (rm, _, _)) r = Map.member r rm++-- | /O(log c)/. Is there a column with the given column key that has at least+-- one value?+--+-- > hasColumn (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 'a' === True+-- > hasColumn (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 'c' === False+hasColumn :: Ord c => Table r c a -> c -> Bool+hasColumn (Table (_, cm, _)) c = Map.member c cm++-- | /O(1)/. Is the table empty?+--+-- > Data.Multimap.Table.null empty === True+-- > Data.Multimap.Table.null (singleton 1 'a' "a") === False+null :: Table r c a -> Bool+null (Table (rm, _, _)) = Map.null rm++-- | /O(1)/. Is the table non-empty?+--+-- > notNull empty === False+-- > notNull (singleton 1 'a' "a") === True+notNull :: Table r c a -> Bool+notNull = not . null++-- | The total number of values for all row and column keys.+--+-- @size@ is evaluated lazily. Forcing the size for the first time takes up to+-- /O(n)/ and subsequent forces take /O(1)/.+--+-- > size empty === 0+-- > size (singleton 1 'a' "a") === 1+-- > size (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) === 3+size :: Table r c a -> Int+size (Table (_, _, sz)) = sz++------------------------------------------------------------------------------++-- | Union two tables, preferring values from the first table+-- upon duplicate keys.+--+-- > union (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")])+-- >   === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")]+union :: (Ord r, Ord c) => Table r c a -> Table r c a -> Table r c a+union = unionWith const++-- | Union a number of tables, preferring values from the leftmost table+-- upon duplicate keys.+--+-- > unions [fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")], fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]]+-- >   === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")]+unions :: (Foldable f, Ord r, Ord c) => f (Table r c a) -> Table r c a+unions = Foldable.foldr union empty++-- | Union two tables with a combining function for duplicate keys.+--+-- > unionWith (++) (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")])+-- >   === fromList [(1,'a',"bc"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")]+unionWith :: (Ord r, Ord c) => (a -> a -> a) -> Table r c a -> Table r c a -> Table r c a+unionWith = unionWithKeys . const . const++-- | Union two tables with a combining function for duplicate keys.+--+-- > let f r c a a' = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ a' in do+-- >   unionWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")])+-- >     === fromList [(1,'a',"1:'a':b|c"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")]+unionWithKeys+  :: (Ord r, Ord c)+  => (r -> c -> a -> a -> a)+  -> Table r c a -> Table r c a -> Table r c a+unionWithKeys f (Table (rm1, cm1, _)) (Table (rm2, cm2, _)) = fromMaps rm cm+  where+    rm = Map.unionWithKey (Map.unionWithKey . f) rm1 rm2+    cm = Map.unionWithKey (Map.unionWithKey . flip f) cm1 cm2++-- | Union a number of tables with a combining function for duplicate keys.+--+-- > unionsWith (++) [fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")], fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]]+-- >   === fromList [(1,'a',"bc"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")]+unionsWith :: (Foldable f, Ord r, Ord c) => (a -> a -> a) -> f (Table r c a) -> Table r c a+unionsWith f = Foldable.foldr (unionWith f) empty++-- | Union a number of tables with a combining function for duplicate keys.+--+-- > let f r c a a' = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ a' in do+-- >   unionsWithKeys f [fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")], fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]]+-- >     === fromList [(1,'a',"1:'a':b|c"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")]+unionsWithKeys+  :: (Foldable f, Ord r, Ord c)+  => (r -> c -> a -> a -> a)+  -> f (Table r c a) -> Table r c a+unionsWithKeys f = Foldable.foldr (unionWithKeys f) empty++-- | Difference of two tables. Return values in the first table whose+-- row and column keys do not have an associated value in the second table.+--+-- > difference (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(1,'b',"d"),(2,'b',"b")])+-- >   === singleton 2 'a' "b"+difference :: (Ord r, Ord c) => Table r c a -> Table r c a -> Table r c a+difference (Table (rm1, cm1, _)) (Table (rm2, cm2, _)) = fromMaps rm cm+  where+    rm = Map.differenceWith ((Just .) . Map.difference) rm1 rm2+    cm = Map.differenceWith ((Just .) . Map.difference) cm1 cm2++------------------------------------------------------------------------------++-- | /O(n)/, assuming the function @a -> b@ takes /O(1)/.+-- Map a function over all values in the table.+--+-- > Data.Multimap.Table.map (++ "x") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) === fromList [(1,'a',"bx"),(1,'b',"cx"),(2,'a',"bx")]+map :: (a -> b) -> Table r c a -> Table r c b+map = mapWithKeys . const . const++-- | /O(n)/, assuming the function @r -> c -> a -> b@ takes /O(1)/.+-- Map a function over all values in the table.+--+-- > mapWithKeys (\r c x -> show r ++ ":" ++ show c ++ ":" ++ x) (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")])+-- >   === fromList [(1,'a',"1:'a':b"),(1,'b',"1:'b':c"),(2,'a',"2:'a':b")]+mapWithKeys :: (r -> c -> a -> b) -> Table r c a -> Table r c b+mapWithKeys f (Table (rm, cm, sz)) = Table (rm', cm', sz)+  where+    rm' = Map.mapWithKey (Map.mapWithKey . f) rm+    cm' = Map.mapWithKey (Map.mapWithKey . flip f) cm++-- | Traverse the (row key, column key, value) triples and collect the results.+--+-- > let f r c a = if odd r && c > 'a' then Just (a ++ "x") else Nothing in do+-- >   traverseWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) === Nothing+-- >   traverseWithKeys f (fromList [(1,'b',"b"),(1,'c',"c"),(3,'d',"b")]) === Just (fromList [(1,'b',"bx"),(1,'c',"cx"),(3,'d',"bx")])+traverseWithKeys+  :: (Applicative t, Ord r, Ord c)+  => (r -> c -> a -> t b)+  -> Table r c a+  -> t (Table r c b)+traverseWithKeys f (Table (rm, _, _)) = fromMaps <$> rm' <*> cm'+  where+    rm' = Map.traverseWithKey (Map.traverseWithKey . f) rm+    cm' = transpose' <$> rm'++-- | Traverse the (row key, column key, value) triples and collect the 'Just' results.+traverseMaybeWithKeys+  :: (Applicative t, Ord r, Ord c)+  => (r -> c -> a -> t (Maybe b))+  -> Table r c a+  -> t (Table r c b)+traverseMaybeWithKeys f (Table (rm, _, _)) = fromMaps <$> rm' <*> cm'+  where+    rm' = Map.traverseWithKey (Map.traverseMaybeWithKey . f) rm+    cm' = transpose' <$> rm'++------------------------------------------------------------------------------++-- | /O(n)/. Fold the values in the table row by row using the given+-- right-associative binary operator.+--+-- > Data.Multimap.Table.foldr (:) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "bcd"+foldr :: (a -> b -> b) -> b -> Table r c a -> b+foldr = foldrWithKeys . const . const++-- | /O(n)/. Fold the values in the table row by row using the given+-- left-associative binary operator.+--+-- > Data.Multimap.Table.foldl (flip (:)) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "dcb"+foldl :: (a -> b -> a) -> a -> Table r c b -> a+foldl f = foldlWithKeys (\a _ _ -> f a)++-- | /O(n)/. Fold the (row key, column key value) triplets in the table+--  row by row using the given right-associative binary operator.+--+-- > let f r c a b = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ b in do+-- >   foldrWithKeys f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "1:'a':b|1:'b':c|2:'a':d|"+foldrWithKeys :: (r -> c -> a -> b -> b) -> b -> Table r c a -> b+foldrWithKeys f b (Table (rm, _, _)) = Map.foldrWithKey f' b rm+  where+    f' = flip . Map.foldrWithKey . f++-- | /O(n)/. Fold the (row key, column key, value) triplets in the table+--  row by row using the given left-associative binary operator.+--+-- > let f a r c b = show r ++ ":" ++ show c ++ ":" ++ b ++ "|" ++ a in do+-- >   foldlWithKeys f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "2:'a':d|1:'b':c|1:'a':b|"+foldlWithKeys :: (a -> r -> c -> b -> a) -> a -> Table r c b -> a+foldlWithKeys f a (Table (rm, _, _)) = Map.foldlWithKey f' a rm+  where+    f' = flip (Map.foldlWithKey . flip f)++-- | /O(n)/. A strict version of 'foldr'. Each application of the+-- operator is evaluated before using the result in the next application.+-- This function is strict in the starting value.+--+-- > Data.Multimap.Table.foldr' (:) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "bcd"+foldr' :: (a -> b -> b) -> b -> Table r c a -> b+foldr' = foldrWithKeys' . const . const++-- | /O(n)/. A strict version of 'foldl'. Each application of the+-- operator is evaluated before using the result in the next application.+-- This function is strict in the starting value.+--+-- > Data.Multimap.Table.foldl' (flip (:)) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "dcb"+foldl' :: (a -> b -> a) -> a -> Table r c b -> a+foldl' f = foldlWithKeys' (\a _ _ -> f a)++-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the+-- operator is evaluated before using the result in the next application.+-- This function is strict in the starting value.+--+-- > let f r c a b = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ b in do+-- >   foldrWithKeys' f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "1:'a':b|1:'b':c|2:'a':d|"+foldrWithKeys' :: (r -> c -> a -> b -> b) -> b -> Table r c a -> b+foldrWithKeys' f b (Table (rm, _, _)) = Map.foldrWithKey' f' b rm+  where+    f' = flip . Map.foldrWithKey' . f++-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the+-- operator is evaluated before using the result in the next application.+-- This function is strict in the starting value.+--+-- > let f a r c b = show r ++ ":" ++ show c ++ ":" ++ b ++ "|" ++ a in do+-- >   foldlWithKeys' f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "2:'a':d|1:'b':c|1:'a':b|"+foldlWithKeys' :: (a -> r -> c -> b -> a) -> a -> Table r c b -> a+foldlWithKeys' f a (Table (rm, _, _)) = Map.foldlWithKey' f' a rm+  where+    f' = flip (Map.foldlWithKey' . flip f)++-- | /O(n)/. Fold the (row key, column key, value) triplets in the map+-- row by row using the given monoid.+--+-- > let f r c a = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" in do+-- >   foldMapWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "1:'a':b|1:'b':c|2:'a':d|"+foldMapWithKeys :: Monoid m => (r -> c -> a -> m) -> Table r c a -> m+foldMapWithKeys f (Table (rm, _, _)) = Map.foldMapWithKey f' rm+  where+    f' = Map.foldMapWithKey . f++------------------------------------------------------------------------------++-- | /O(r)/. Return a mapping from column keys to values for the given+-- row key.+--+-- > row 1 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.fromList [('a',"b"),('b',"c")]+-- > row 3 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.empty+row :: Ord r => r -> Table r c a -> Map c a+row r (Table (rm, _, _)) = Map.findWithDefault Map.empty r rm++-- | /O(c)/. Return a mapping from row keys to values for the given+-- column key.+--+-- > column 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.fromList [(1,"b"),(2,"d")]+-- > column 'c' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.empty+column :: Ord c => c -> Table r c a -> Map r a+column c (Table (_, cm, _)) = Map.findWithDefault Map.empty c cm++-- | Return a mapping from row keys to maps from column keys to values.+--+-- > rowMap (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")])+-- >   === Map.fromList [(1, Map.fromList [('a',"b"),('b',"c")]),(2, Map.fromList [('a',"d")])]+rowMap :: Table r c a -> Map r (Map c a)+rowMap (Table (rm, _, _)) = rm++-- | Return a mapping from column keys to maps from row keys to values.+--+-- > columnMap (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")])+-- >   === Map.fromList [('a', Map.fromList [(1,"b"),(2,"d")]),('b', Map.fromList [(1,"c")])]+columnMap :: Table r c a -> Map c (Map r a)+columnMap (Table (_, cm, _)) = cm++-- | Return, in ascending order, the list of all row keys of that have+-- at least one value in the table.+--+-- > rowKeys (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [1,2]+rowKeys :: Table r c a -> [r]+rowKeys (Table (rm, _, _)) = Map.keys rm++-- | Return, in ascending order, the list of all column keys of that have+-- at least one value in the table.+--+-- > columnKeys (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === ['a','b']+columnKeys :: Table r c a -> [c]+columnKeys (Table (_, cm, _)) = Map.keys cm++-- | Return the set of all row keys of that have at least one value+-- in the table.+--+-- > rowKeysSet (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Set.fromList [1,2]+rowKeysSet :: Table r c a -> Set r+rowKeysSet (Table (rm, _, _)) = Map.keysSet rm++-- | Return the set of all column keys of that have at least one value+-- in the table.+--+-- > columnKeysSet (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Set.fromList ['a','b']+columnKeysSet :: Table r c a -> Set c+columnKeysSet (Table (_, cm, _)) = Map.keysSet cm++-- | Convert the table into a list of (row key, column key, value) triples.+--+-- > toList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]+toList :: Table r c a -> [(r, c, a)]+toList (Table (rm, _, _)) = Map.toList (Map.toList <$> rm) >>= distr++-- | Convert the table into a list of (row key, column key, value) triples+-- in ascending order of row keys, and ascending order of column keys+-- with a row.+--+-- > toRowAscList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]+toRowAscList :: Table r c a -> [(r, c, a)]+toRowAscList (Table (rm, _, _)) = Map.toAscList (Map.toAscList <$> rm) >>= distr++-- | Convert the table into a list of (column key, row key, value) triples+-- in ascending order of column keys, and ascending order of row keys+-- with a column.+--+-- > toColumnAscList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [('a',1,"b"),('a',2,"d"),('b',1,"c")]+toColumnAscList :: Table r c a -> [(c, r, a)]+toColumnAscList (Table (_, cm, _)) = Map.toAscList (Map.toAscList <$> cm) >>= distr++-- | Convert the table into a list of (row key, column key, value) triples+-- in descending order of row keys, and descending order of column keys+-- with a row.+--+-- > toRowDescList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [(2,'a',"d"),(1,'b',"c"),(1,'a',"b")]+toRowDescList :: Table r c a -> [(r, c, a)]+toRowDescList (Table (rm, _, _)) = Map.toDescList (Map.toDescList <$> rm) >>= distr++-- | Convert the table into a list of (column key, row key, value) triples+-- in descending order of column keys, and descending order of row keys+-- with a column.+--+-- > toColumnDescList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [('b',1,"c"),('a',2,"d"),('a',1,"b")]+toColumnDescList :: Table r c a -> [(c, r, a)]+toColumnDescList (Table (_, cm, _)) = Map.toDescList (Map.toDescList <$> cm) >>= distr++------------------------------------------------------------------------------++-- | /O(n)/, assuming the predicate function takes /O(1)/.+-- Retain all values that satisfy the predicate.+--+-- > Data.Multimap.Table.filter (> "c") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 2 'a' "d"+-- > Data.Multimap.Table.filter (> "d") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === empty+filter :: (a -> Bool) -> Table r c a -> Table r c a+filter = filterWithKeys . const . const++-- | /O(r)/, assuming the predicate function takes /O(1)/.+-- Retain all rows that satisfy the predicate.+--+-- > filterRow even (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 2 'a' "d"+filterRow :: (r -> Bool) -> Table r c a -> Table r c a+filterRow p (Table (rm, cm, _)) = Table (rm', nonEmpty cm', size' rm')+  where+    rm' = Map.filterWithKey (const . p) rm+    cm' = Map.map (Map.filterWithKey (const . p)) cm++-- | /O(c)/, assuming the predicate function takes /O(1)/.+-- Retain all columns that satisfy the predicate.+--+-- > filterColumn (> 'a') (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "c"+filterColumn :: (c -> Bool) -> Table r c a -> Table r c a+filterColumn p (Table (rm, cm, _)) = Table (nonEmpty rm', cm', size' cm')+  where+    rm' = Map.map (Map.filterWithKey (const . p)) rm+    cm' = Map.filterWithKey (const . p) cm++-- | /O(c)/, assuming the predicate function takes /O(1)/.+-- Retain all (row key, column key, value) triples that satisfy the predicate.+--+-- > filterWithKeys (\r c a -> odd r && c > 'a' && a > "b") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "c"+filterWithKeys+  :: (r -> c -> a -> Bool)+  -> Table r c a+  -> Table r c a+filterWithKeys p (Table (rm, cm, _)) = fromMaps rm' cm'+  where+    rm' = Map.mapWithKey (Map.filterWithKey . p) rm+    cm' = Map.mapWithKey (Map.filterWithKey . flip p) cm++-- | /O(n)/, assuming the function @a -> 'Maybe' b@ takes /O(1)/.+-- Map values and collect the 'Just' results.+--+-- > mapMaybe (\a -> if a == "a" then Just "new a" else Nothing) (fromList [(1,'a',"a"),(1,'b',"c"),(2,'b',"a")])+-- >   === fromList [(1,'a',"new a"),(2,'b',"new a")]+mapMaybe :: (a -> Maybe b) -> Table r c a -> Table r c b+mapMaybe = mapMaybeWithKeys . const . const++-- | /O(n)/, assuming the function @r -> c -> a -> 'Maybe' b@ takes /O(1)/.+-- Map (row key, column key, value) triples and collect the 'Just' results.+--+-- > let f r c a = if r == 1 && a == "c" then Just "new c" else Nothing in do+-- >   mapMaybeWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "new c"+mapMaybeWithKeys :: (r -> c -> a -> Maybe b) -> Table r c a -> Table r c b+mapMaybeWithKeys f (Table (rm, cm, _)) = fromMaps rm' cm'+  where+    rm' = Map.mapWithKey (Map.mapMaybeWithKey . f) rm+    cm' = Map.mapWithKey (Map.mapMaybeWithKey . flip f) cm++-- | /O(n)/, assuming the function @a -> 'Either' a1 a2@ takes /O(1)/.+-- Map values and separate the 'Left' and 'Right' results.+--+-- > mapEither (\a -> if a == "a" then Left a else Right a) (fromList [(1,'a',"a"),(1,'b',"c"),(2,'b',"a")])+-- >   === (fromList [(1,'a',"a"),(2,'b',"a")],fromList [(1,'b',"c")])+mapEither :: (a -> Either a1 a2) -> Table r c a -> (Table r c a1, Table r c a2)+mapEither = mapEitherWithKeys . const . const++-- | /O(n)/, assuming the function @r -> c -> a -> 'Either' a1 a2@ takes /O(1)/.+-- Map (row key, column key, value) triples and separate the 'Left' and 'Right' results.+--+-- > mapEitherWithKeys (\r c a -> if r == 1 && c == 'a' then Left a else Right a) (fromList [(1,'a',"a"),(1,'b',"c"),(2,'b',"a")])+-- >   === (fromList [(1,'a',"a")],fromList [(1,'b',"c"),(2,'b',"a")])+mapEitherWithKeys :: (r -> c -> a -> Either a1 a2) -> Table r c a -> (Table r c a1, Table r c a2)+mapEitherWithKeys f (Table (rm, cm, _)) = (fromMaps rm1 cm1, fromMaps rm2 cm2)+  where+    (rm1, rm2) = (fmap fst &&& fmap snd) $ Map.mapWithKey (Map.mapEitherWithKey . f) rm+    (cm1, cm2) = (fmap fst &&& fmap snd) $ Map.mapWithKey (Map.mapEitherWithKey . flip f) cm++------------------------------------------------------------------------------+-- * Non exported functions+------------------------------------------------------------------------------++assoc :: (a, (b, c)) -> (a, b, c)+assoc (a, (b, c)) = (a, b, c)++distr :: (a, [(b, c)]) -> [(a, b, c)]+distr = fmap assoc . uncurry (zip . repeat)++-- | Build a table from a row map and a column map.+fromMaps :: Map r (Map c a) -> Map c (Map r a) -> Table r c a+fromMaps rm cm = Table (rm', cm', size' rm')+  where+    rm' = nonEmpty rm+    cm' = nonEmpty cm++fromMaps' :: (Ord r, Ord c) => r -> c -> Map r (Map c a) -> Map c (Map r a) -> Table r c a+fromMaps' r c rm cm = Table (rm', cm', size' rm')+  where+    rm' = nonEmpty' r rm+    cm' = nonEmpty' c cm++nonEmpty :: Map k1 (Map k2 a) -> Map k1 (Map k2 a)+nonEmpty = Map.filter (not . Map.null)++nonEmpty' :: Ord k1 => k1 -> Map k1 (Map k2 a) -> Map k1 (Map k2 a)+nonEmpty' k1 m = case Map.lookup k1 m of+  Just m' | Map.null m' -> Map.delete k1 m+  _ -> m++transpose' :: (Ord r, Ord c) => Map r (Map c a) -> Map c (Map r a)+transpose' = Map.foldrWithKey' f Map.empty+  where+    f r = Map.unionWith Map.union . Map.map (Map.singleton r)++size' :: Map k1 (Map k2 a) -> Int+size' = Foldable.sum . fmap Map.size++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f ~(a, b, c) = f a b c
quick-process.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name:          quick-process-version:       0.0.1+version:       0.0.3 synopsis:      Run external processes verified at compilation/installation description:     The library checks program name during compilation, generates exec spec@@ -205,7 +205,7 @@     >         [ Subcase "FindPrintf"     >           (KeyArg @(Refined (Regex "^[%][fpactbnM%]$") String) "-printf" .*. HNil)     >         , Subcase "FindExec"-    >           (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArg "{}" .*. ConstArg ";" .*. HNil)+    >           (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArgs (words "{} ;") .*. HNil)     >         ]     >   .*. HNil     >   )@@ -214,6 +214,36 @@     Note usage of @Regex@ predicate - thanks to     <https://hackage.haskell.org/package/refined sbv> and z3 SMT solver     values satisfing arbitrary TDFA regex can be generated.+    +    === Init Cascade+    #init-cascade#+    +    A call spec may require another command to be executed somewhere in the+    past e.g. most of git commands work only with initialize repository.+    +    > {-# LANGUAGE TemplateHaskell #-}+    > module CallSpecs where+    >+    > import CallSpecs.GitInit qualified as I+    > import System.Process.Quick+    >+    > $(genCallSpec+    >   [SandboxValidate]+    >   "git"+    >   (   ConstArg "remote"+    >   .*. StdErrMatches "^$"+    >   .*. StdOutMatches "^$"+    >   .*. Init @I.Git+    >   .*. HNil+    >   )+    >  )+    +    == Generated TH code inspection+    #generated-th-code-inspection#+    +    GHC prints generated TH code with pragma:+    +    > {-# OPTIONS_GHC -ddump-splices #-}  homepage:      http://github.com/yaitskov/quick-process license:       BSD-3-Clause@@ -226,7 +256,7 @@ extra-doc-files:   changelog.md tested-with:-  GHC == 9.10.1+  GHC == 9.10.1, GHC == 9.12.2  source-repository head   type:@@ -244,17 +274,98 @@   default-extensions:     DefaultSignatures     NoImplicitPrelude+    OverloadedLabels     OverloadedStrings     TemplateHaskell   build-depends:-      HList >= 0.5.4.0 && < 1-    , QuickCheck >= 2.14.3 && < 3-    , base >=4 && < 5+      QuickCheck >= 2.14.3 && < 3+    , base >=4.7 && < 5     , bytestring >= 0.12.1 && < 1     , generic-lens >= 2.2.2 && < 3     , lens >= 5.3.2 && < 6     , relude >= 1.2.2 && < 2 +library hlist-internal+  hs-source-dirs: hlist+  Build-Depends:       base >= 4.7 && < 5,+                       -- for Typeable '[] and '(:) with ghc-7.6+                       base-orphans < 1,+                       template-haskell < 3,+                       ghc-prim < 0.16,+                       mtl  >= 2.3.1 && < 3,+                       tagged < 1,+                       profunctors >= 5.6.2 && < 6,+                       array < 1+  Exposed-modules:     Data.HList,+                       Data.HList.CommonMain,+                       Data.HList.Data,+                       Data.HList.Dredge,+                       Data.HList.FakePrelude,+                       Data.HList.HArray,+                       Data.HList.HCurry,+                       Data.HList.HList,+                       Data.HList.HListPrelude,+                       Data.HList.HOccurs,+                       Data.HList.HTypeIndexed,+                       Data.HList.HSort,+                       Data.HList.HZip,+                       Data.HList.Keyword,+                       Data.HList.Label3,+                       Data.HList.Label5,+                       Data.HList.Label6,+                       Data.HList.Labelable,+                       Data.HList.MakeLabels,+                       Data.HList.Record,+                       Data.HList.RecordPuns,+                       Data.HList.RecordU,+                       Data.HList.TIC,+                       Data.HList.TIP,+                       Data.HList.TIPtuple,+                       Data.HList.TypeEqO,+                       Data.HList.Variant+  Other-modules:       LensDefs+  Default-Language:    Haskell2010+  Ghc-Options:         -Wall -fno-warn-missing-signatures+                       -fno-warn-orphans+                       -fno-warn-unticked-promoted-constructors+                       -Wno-star-is-type+  Default-Extensions:  ConstraintKinds+                       DataKinds+                       DeriveDataTypeable+                       EmptyDataDecls+                       FlexibleContexts+                       FlexibleInstances+                       FunctionalDependencies+                       GeneralizedNewtypeDeriving+                       GADTs+                       KindSignatures+                       MultiParamTypeClasses+                       PolyKinds+                       RankNTypes+                       ScopedTypeVariables+                       StandaloneDeriving+                       TypeFamilies+                       TypeOperators+                       UndecidableInstances+                       StarIsType+                       UndecidableSuperClasses+                       AllowAmbiguousTypes+                       RoleAnnotations+  Other-Extensions:    CPP+                       TemplateHaskell+                       OverlappingInstances++library multi-containers-internal+  hs-source-dirs: multi-containers+  exposed-modules:+    Data.Multimap.Table+    Data.Multimap.Table.Internal+  build-depends:+      base >=4.7 && <5+    , containers >=0.5.10.2 && <0.8+  default-language: Haskell2010+  ghc-options: -Wall+ -- https://github.com/erikd/conduit-find/pull/17 library conduit-find-internal   import: base@@ -318,10 +429,15 @@     System.Process.Quick.CallEffect     System.Process.Quick.CallArgument     System.Process.Quick.CallSpec+    System.Process.Quick.CallSpec.Init     System.Process.Quick.CallSpec.Run     System.Process.Quick.CallSpec.Subcases     System.Process.Quick.CallSpec.Type     System.Process.Quick.CallSpec.Verify+    System.Process.Quick.CallSpec.Verify.ImportOverlook+    System.Process.Quick.CallSpec.Verify.Sandbox+    System.Process.Quick.CallSpec.Verify.TrailingHelp+    System.Process.Quick.CallSpec.Verify.Type     System.Process.Quick.OrphanArbitrary     System.Process.Quick.Predicate     System.Process.Quick.Predicate.ImplDir@@ -333,6 +449,7 @@     System.Process.Quick.Pretty     System.Process.Quick.Sbv.Arbitrary     System.Process.Quick.TdfaToSbvRegex+    System.Process.Quick.Util   build-depends:       casing                  < 1     , conduit                 < 2@@ -340,9 +457,14 @@     , containers              < 1     , directory               < 2     , filepath                < 2+    , generic-data            < 2+    , generic-deriving        < 2     , generic-random          < 2+    , hlist-internal+    , monad-time              < 1     , mtl                     < 3-    , pretty                  < 2+    , multi-containers-internal+    , pretty-simple           < 5     , process                 < 2     , refined-internal     , regex-compat            < 1@@ -352,8 +474,10 @@     , template-haskell        < 3     , temporary               < 2     , th-utilities            < 1-    , trace-embrace           < 2+    , time                    < 2+    , trace-embrace           >= 1.2.0 && < 2     , unix                    < 3+    , wl-pprint-text          < 2  test-suite verify-call-specs   import: base@@ -365,7 +489,9 @@   hs-source-dirs:     verify-call-specs   ghc-options: -Wall -rtsopts -threaded -main-is VerifyCallSpecs-  build-depends: quick-process+  build-depends:+      quick-process+    , hlist-internal  test-suite sandbox-effect   import: base@@ -376,11 +502,16 @@     CallSpecs.CpManyToDir     CallSpecs.Date     CallSpecs.FindCases+    CallSpecs.GitInit+    CallSpecs.GitInitExit1+    CallSpecs.GitRemote+    CallSpecs.GitSubcases   hs-source-dirs:     sandbox-effect   ghc-options: -Wall -rtsopts -threaded -main-is SandBoxEffect   build-depends:       quick-process+    , hlist-internal     , refined-internal  test-suite test@@ -403,6 +534,7 @@   ghc-options: -Wall -rtsopts -threaded -main-is Driver   build-depends:       directory+    , hlist-internal     , quickcheck-instances     , refined-internal     , th-utilities
sandbox-effect/CallSpecs/FindCases.hs view
@@ -15,7 +15,7 @@         [ Subcase "FindPrintf"           (KeyArg @(Refined (Regex "^[%][fpactbnM%]$") String) "-printf" .*. HNil)         , Subcase "FindExec"-          (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArg "{}" .*. ConstArg ";" .*. HNil)+          (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArgs ["{}", ";"] .*. HNil)         ]   .*. HNil   )
+ sandbox-effect/CallSpecs/GitInit.hs view
@@ -0,0 +1,18 @@+-- {-# OPTIONS_GHC -ddump-splices #-}+module CallSpecs.GitInit where++import Data.String qualified as S+import System.Process.Quick+import System.Process.Quick.Prelude++$(genCallSpec+  [TrailingHelpValidate, SandboxValidate]+  "git"+  (   ConstArgs (S.words "-c init.defaultBranch=master init")+  .*. ExitCodeEqualTo ExitSuccess+  .*. StdErrMatches "^$"+  .*. StdOutMatches "^Initialized empty Git repository"+  .*. DirCreated ".git"+  .*. HNil+  )+ )
+ sandbox-effect/CallSpecs/GitInitExit1.hs view
@@ -0,0 +1,17 @@+-- {-# OPTIONS_GHC -ddump-splices #-}+module CallSpecs.GitInitExit1 where++import System.Process.Quick+import System.Process.Quick.Prelude++$(genCallSpec+  [TrailingHelpValidate, SandboxValidate]+  "git"+  (   ConstArg "initt"+  .*. ExitCodeEqualTo (ExitFailure 1)+  .*. StdErrMatches "is not a git command"+  .*. StdOutMatches "^$"+  -- .*. DirCreated ".git"+  .*. HNil+  )+ )
+ sandbox-effect/CallSpecs/GitRemote.hs view
@@ -0,0 +1,16 @@+-- {-# OPTIONS_GHC -ddump-splices #-}+module CallSpecs.GitRemote where++import CallSpecs.GitInit qualified as I+import System.Process.Quick++$(genCallSpec+  [SandboxValidate]+  "git"+  (   ConstArg "remote"+  .*. StdErrMatches "^$"+  .*. StdOutMatches "^$"+  .*. Init @I.Git+  .*. HNil+  )+ )
+ sandbox-effect/CallSpecs/GitSubcases.hs view
@@ -0,0 +1,31 @@+-- {-# OPTIONS_GHC -ddump-splices #-}+module CallSpecs.GitSubcases where++import CallSpecs.GitInit qualified as I+import Data.String qualified as S+import System.Process.Quick+import System.Process.Quick.Prelude++$(genCallSpec+  [TrailingHelpValidate, SandboxValidate]+  "git"+  (   ConstArgs (S.words "--no-pager --no-replace-objects")+  .*. Subcases "GitSubCases"+      [ Subcase "Success"+        (   ConstArg "reset"+        .*. StdErrMatches "^$"+        .*. StdOutMatches "^$"+        .*. Init @I.Git+        .*. HNil+        )+      , Subcase "Fail"+        (  ConstArg "initt"+        .*. ExitCodeEqualTo (ExitFailure 1)+        .*. StdErrMatches "is not a git command"+        .*. StdOutMatches "^$"+        .*. HNil+        )+      ]+  .*. HNil+  )+ )
sandbox-effect/SandBoxEffect.hs view
@@ -5,10 +5,18 @@ import CallSpecs.CpManyToDir () import CallSpecs.Date import CallSpecs.FindCases ()+import CallSpecs.GitInit ()+import CallSpecs.GitInitExit1 ()+import CallSpecs.GitRemote ()+import CallSpecs.GitSubcases () import System.Process.Quick import System.Process.Quick.Prelude  main :: IO () main = do-  $(discoverAndVerifyCallSpecs (fromList [SandboxValidate]) 1)+  startedAt <- currentTime+  $(discoverAndVerifyCallSpecs (fromList [SandboxValidate]) 3)+  endedAt <- currentTime+  putStrLn $ "Execution of expr generated by discoverAndVerifyCallSpecs took " <>+    show (endedAt `diffUTCTime` startedAt)   callProcess $ Date $$(refineTH "+%Y")
src/System/Process/Quick.hs view
@@ -3,7 +3,9 @@ import Data.HList as M (HList(..), (.*.)) import Refined as M import System.Process.Quick.CallArgument as M+import System.Process.Quick.CallEffect as M import System.Process.Quick.CallSpec as M+import System.Process.Quick.CallSpec.Init as M import System.Process.Quick.CallSpec.Run as M import System.Process.Quick.CallSpec.Subcases as M import System.Process.Quick.CallSpec.Verify as M
src/System/Process/Quick/CallArgument.hs view
@@ -3,7 +3,9 @@ import Control.Monad.Writer.Strict import Data.HList import Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax qualified as TH import Refined as M hiding (NonEmpty)+import System.Process.Quick.CallEffect import System.Process.Quick.OrphanArbitrary () import System.Process.Quick.Prelude hiding (Text) import TH.Utilities qualified as TU@@ -49,6 +51,7 @@ instance Quote QR where   newName n = QR $ lift (newName n) +-- data class (Typeable a) => CallArgumentGen a where   -- | field name in the record; constant value does not have a field   cArgName :: a -> Maybe String@@ -57,13 +60,33 @@   progArgExpr :: a -> QR Exp   -- | TH field definition of call argument in CallSpec record   fieldExpr :: a -> QR (Maybe VarBangType)+  -- | Exp type is '\v -> [OutcomeChecker]'+  outcomeCheckersExpr :: a -> QR Exp+  outcomeCheckersExpr _ = [| const [] |]+  -- | Exp type is '\v -> m [CsBox]'+  initCallSpecsExpr :: a -> QR Exp -newtype ConstArg = ConstArg String deriving (Eq, Show, Typeable)+instance CallArgumentGen OutcomeChecker where+  cArgName _ = Nothing+  progArgExpr _ = [| const [] |]+  fieldExpr _ = pure Nothing+  outcomeCheckersExpr c =  [| pure [$(TH.lift c)] |]+  initCallSpecsExpr _ = [| pure . const [] |]++newtype ConstArg = ConstArg String deriving (Eq, Show) instance CallArgumentGen ConstArg where   cArgName _ = Nothing   progArgExpr (ConstArg c) = [| const [ $(stringE c)] |]   fieldExpr _ = pure Nothing+  initCallSpecsExpr _ = [| pure . const [] |] +newtype ConstArgs = ConstArgs [String] deriving (Eq, Show)+instance CallArgumentGen ConstArgs where+  cArgName _ = Nothing+  progArgExpr (ConstArgs cs) = [| const $(TH.lift cs) |]+  fieldExpr _ = pure Nothing+  initCallSpecsExpr _ = [| pure . const [] |]+ defaultBang :: Bang defaultBang = Bang NoSourceUnpackedness NoSourceStrictness @@ -96,7 +119,7 @@         | otherwise -> filteredFieldName  -- | Command line argument without preceeding key-newtype VarArg a = VarArg String deriving (Eq, Show, Typeable)+newtype VarArg a = VarArg String deriving (Eq, Show) instance (Typeable a, CallArgument a) => CallArgumentGen (VarArg a) where   cArgName (VarArg n) = Just n   progArgExpr (VarArg fieldName) =@@ -106,11 +129,13 @@     Just . (mkName $ escapeFieldName fieldName, defaultBang,) <$> atRep     where       atRep = QR . lift $ TU.typeRepToType (typeRep (Proxy @a))+  initCallSpecsExpr _ = [| pure . const [] |]  -- | Command line argument prefixed with a key-newtype KeyArg a = KeyArg String deriving (Eq, Show, Typeable)+newtype KeyArg a = KeyArg String deriving (Eq, Show) instance (Typeable a, CallArgument a) => CallArgumentGen (KeyArg a) where   cArgName (KeyArg n) = cArgName (VarArg @a n)   progArgExpr (KeyArg fieldName) =     [| \x -> $(progArgExpr (ConstArg fieldName)) x <> $(progArgExpr (VarArg @a fieldName)) x |]   fieldExpr (KeyArg fieldName) = fieldExpr (VarArg @a fieldName)+  initCallSpecsExpr _ = [| pure . const [] |]
src/System/Process/Quick/CallEffect.hs view
@@ -1,10 +1,21 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ module System.Process.Quick.CallEffect where -import System.Posix++import System.Directory ( doesDirectoryExist, doesFileExist )+import System.Posix ( FileMode ) import System.Process.Quick.Prelude import Text.Regex.TDFA-import Prelude (Show (..))+    ( RegexLike(matchTest),+      RegexMaker(makeRegexOpts),+      RegexOptions(defaultCompOpt),+      CompOption(multiline),+      ExecOption(ExecOption),+      Regex ) +import Language.Haskell.TH.Syntax ( Lift )+ data TimeReference   = LaunchTime   | BootTime@@ -26,34 +37,69 @@   | FsOr [FsEffect]   deriving (Show, Eq) -data ViRex = ViRex ByteString Regex--instance Show ViRex where-  show (ViRex bs _) = Prelude.show bs--instance Eq ViRex where-  (ViRex a _) == (ViRex b _) = a == b--data OutMatcher-  = ExactMatching ByteString-  | WholeMatching ViRex -- read all input-  | LineMatching ViRex -- consume file line by line - at least one line match-  deriving (Show, Eq)+data Mismatch a+  = Mismatch+    { expected :: a+    , got ::a+    } deriving (Show, Eq)  data CallEffect   = SleepFor Integer -- call lasts at least N microseconds-  | ExitCode Int -- expected exit code+  | ExitCode (Mismatch ExitCode) -- expected exit code   | FsEffect FsEffect   | OrCe [CallEffect]   | AndCe [CallEffect]   | NotCe [CallEffect]-  | StdOutputCe OutMatcher-  | StdErrorCe OutMatcher+  | StdOutputCe { rx :: String, output :: String }+  | StdErrorCe { rx :: String, output :: String }   deriving (Show, Eq) --- | instances are generated for types with CallSpec and Subcases--- The class is introduced because,--- expected effects don't have fields in a CallSpec record-class CallSpecEffect cse where-  -- call after callSpec in the same directory-  unsatisfiedEffects :: MonadIO m => cse -> m [CallEffect]+-- move to module for orphan instances+deriving instance Lift ExitCode+deriving instance Data ExitCode++data CsExecReport+  = CsExecReport+    { exitCode :: ExitCode+    , stdErr :: String+    , stdOut :: String+    , execTime :: NominalDiffTime+    , processDir :: FilePath+    } deriving (Show, Eq)++class CallSpecOutcomeCheck c where+  -- | call after callSpec in the same directory+  check :: MonadIO m => CsExecReport -> c -> m [CallEffect]++data OutcomeChecker+  = ExitCodeEqualTo ExitCode+  | StdErrMatches String+  | StdOutMatches String+  | FileCreated FilePath+  | DirCreated FilePath+  deriving (Show, Eq, Data, Generic, Lift)+  -- | ConcatOutcomeChecker [OutcomeChecker]+  -- | BothOutcomeChecker OutcomeChecker OutcomeChecker++parseRx :: String -> Regex+parseRx = makeRegexOpts defaultCompOpt { multiline = False } (ExecOption False)++instance CallSpecOutcomeCheck OutcomeChecker where+  check cser | $(tr "/cser") True = \case+    ExitCodeEqualTo eec+      | eec == exitCode cser -> pure []+      | otherwise -> pure [ExitCode . Mismatch eec $ exitCode cser]+    StdErrMatches rx+      | parseRx rx `matchTest` stdErr cser -> pure []+      | otherwise -> pure [StdErrorCe rx $ stdErr cser]+    StdOutMatches rx+      | parseRx rx `matchTest` stdOut cser -> pure []+      | otherwise -> pure [StdOutputCe rx $ stdOut cser]+    FileCreated dp ->+      liftIO (doesFileExist dp) >>= \case+        True -> pure []+        False -> pure [FsEffect $ FsPathPredicate dp [FsExists]]+    DirCreated dp ->+      liftIO (doesDirectoryExist dp) >>= \case+        True -> pure []+        False -> pure [FsEffect $ FsPathPredicate dp [FsExists]]
src/System/Process/Quick/CallSpec.hs view
@@ -15,9 +15,11 @@ import System.Directory import System.Process.Quick.CallArgument import System.Process.Quick.CallSpec.Type as E+import System.Process.Quick.CallSpec.Verify.ImportOverlook import System.Process.Quick.Prelude import Text.Casing import Text.Regex+import System.Process.Quick.Util  type FoldrConstr l a = (HFoldr (Mapcar (Fun CallArgumentGen (QR a))) [QR a] l [QR a]) @@ -59,6 +61,10 @@   , funD' 'programArgs []       [| concat . flap $(listE (hMapM (Fun progArgExpr :: Fun CallArgumentGen (QR Exp)) l)) |]   , funD' 'verificationMethods [ [p|_|] ] (THS.lift $ sort verMethods)+  , funD' 'outcomeCheckers []+      [| concat . flap $(listE (hMapM (Fun outcomeCheckersExpr :: Fun CallArgumentGen (QR Exp)) l)) |]+  , funD' 'initCallSpecs []+      [| fmap concat . sequence . flap $(listE (hMapM (Fun initCallSpecsExpr :: Fun CallArgumentGen (QR Exp)) l)) |]   ]  mkName' :: NonEmptyStr -> Name@@ -70,10 +76,13 @@   [VerificationMethod] -> String -> HList l -> Q [Dec] genCallSpec verMethods progName l = do   runIO . whenNothingM_ (findExecutable progName) . fail $ "Program " <> show progName <> " is not found"-  maybe err (g . mkName') (programNameToHsIdentifier progName)+  pkgName <- loc_module <$> location+  addCompiledCallSpec (ConT . mkName . joinNe pkgName '.' $ toList csBaseName)+  go $ mkName' csBaseName   where-    err = fail $ "Call spec name is bad: " <> show progName <> " " <> show l-    g recName = do+    csBaseName = maybe err id (programNameToHsIdentifier progName)+    err = error $ "Call spec name is bad: " <> show progName <> " " <> show l+    go recName = do       (a, w) <- runWriterT . unQR $ sequence         [ genCallArgsRecord recName l         , genCallSpecInstance verMethods recName progName l
+ src/System/Process/Quick/CallSpec/Init.hs view
@@ -0,0 +1,28 @@+module System.Process.Quick.CallSpec.Init where++import Language.Haskell.TH as TH+import System.Process.Quick.CallArgument+import System.Process.Quick.CallSpec+import System.Process.Quick.Prelude+import TH.Utilities qualified as TU++data Init cs = Init deriving (Show, Eq, Ord, Data)++instance CallSpec cs => CallArgumentGen (Init cs) where+  cArgName _ = Nothing+  -- Exp type is '\v -> [String]'+  progArgExpr _ = [| const [] |]+  fieldExpr _ = pure Nothing+  -- | Exp type is '\v -> m [CsBox]'+  initCallSpecsExpr _ = do+    -- [| const (sequence [generate (arbitrary @cs)]) |]+    trep <- QR $ lift $ TU.typeRepToType (typeRep (Proxy @cs))+    pure (AppE (VarE 'const)+          (AppE (VarE 'liftIO)+            (AppE (VarE 'sequence)+              (ListE+                [ AppE+                  (AppE (VarE 'fmap) (ConE 'CsBox))+                  (AppE (VarE 'generate)+                    (AppTypeE (VarE 'arbitrary) trep))+                ]))))
src/System/Process/Quick/CallSpec/Run.hs view
@@ -4,22 +4,22 @@ import System.Process.Quick.CallSpec.Type import System.Process qualified as SP --- | See 'SP.callProcess'+-- | See 'System.Process.callProcess' callProcess :: (MonadIO m, CallSpec cs) => cs -> m () callProcess cs = liftIO $ SP.callProcess (programName $ pure cs) (programArgs cs) --- | See 'SP.spawnProcess'+-- | See 'System.Process.spawnProcess' spawnProcess :: (MonadIO m, CallSpec cs) => cs -> m SP.ProcessHandle spawnProcess cs = liftIO $ SP.spawnProcess (programName $ pure cs) (programArgs cs) --- | See 'SP.readProcess'+-- | See 'System.Process.readProcess' readProcess :: (MonadIO m, CallSpec cs) => cs -> String -> m String readProcess cs input = liftIO $ SP.readProcess (programName $ pure cs) (programArgs cs) input --- | See 'SP.readProcessWithExitCode'+-- | See 'System.Process.readProcessWithExitCode' readProcessWithExitCode :: (MonadIO m, CallSpec cs) => cs -> String -> m (ExitCode, String, String) readProcessWithExitCode cs input = liftIO $ SP.readProcessWithExitCode (programName $ pure cs) (programArgs cs) input --- | See 'SP.proc'+-- | See 'System.Process.proc' proc :: CallSpec cs => cs -> CreateProcess proc cs = SP.proc (programName $ pure cs) (programArgs cs)
src/System/Process/Quick/CallSpec/Subcases.hs view
@@ -59,10 +59,30 @@                       , genArbitraryInstance (mkName tyCon)                       ]     [| $(lamCasesE (subcaseToClause <$> cases)) . $(varE . mkName $ mapFirst toLower tyCon) |]--   fieldExpr (Subcases (TcName tyCon) _) =     pure $ Just ( mkName $ mapFirst toLower tyCon                 , defaultBang                 , ConT $ mkName tyCon                 )+  outcomeCheckersExpr (Subcases (TcName tyCon) cases) = do+    [| $(lamCasesE (subcaseToClause' <$> cases)) . $(varE . mkName $ mapFirst toLower tyCon) |]+    where+      subcaseToClause' :: Subcase -> QR Clause+      subcaseToClause' (Subcase (DcName dcName) l) = do+        x <- newName "x"+        f <- [| concat . flap $(listE (hMapM (Fun outcomeCheckersExpr :: Fun CallArgumentGen (QR Exp)) l)) |]+        pure $ Clause+          [AsP x (RecP (mkName dcName) [])]+          (NormalB (AppE f (VarE x)))+          []+  initCallSpecsExpr (Subcases (TcName tyCon) cases) = do+    [| $(lamCasesE (subcaseToClause' <$> cases)) . $(varE . mkName $ mapFirst toLower tyCon) |]+    where+      subcaseToClause' :: Subcase -> QR Clause+      subcaseToClause' (Subcase (DcName dcName) l) = do+        x <- newName "x"+        f <- [| fmap concat . sequence . flap $(listE (hMapM (Fun initCallSpecsExpr :: Fun CallArgumentGen (QR Exp)) l)) |]+        pure $ Clause+          [AsP x (RecP (mkName dcName) [])]+          (NormalB (AppE f (VarE x)))+          []
src/System/Process/Quick/CallSpec/Type.hs view
@@ -1,15 +1,24 @@ module System.Process.Quick.CallSpec.Type where +import System.Process.Quick.CallEffect ( OutcomeChecker ) import System.Process.Quick.Prelude-import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Syntax ( Lift )  -- | DC definition order defines validation order data VerificationMethod   = TrailingHelpValidate   | SandboxValidate-  deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift)+  deriving (Show, Ord, Eq, Data, Bounded, Enum, Generic, Lift) -class (Arbitrary cs, Data cs) => CallSpec cs where+instance Pretty VerificationMethod where+  pretty = show++class (Show cs, Arbitrary cs, Data cs) => CallSpec cs where   programName :: Proxy cs -> String   programArgs :: cs -> [String]   verificationMethods :: Proxy cs -> [VerificationMethod]+  outcomeCheckers :: cs -> [OutcomeChecker]+  initCallSpecs :: MonadIO m => cs -> m [CsBox]++-- avoid UndecidableInstances for init dependent CallSpecs+data CsBox = forall cs. CallSpec cs => CsBox { unCsBox :: cs }
src/System/Process/Quick/CallSpec/Verify.hs view
@@ -1,72 +1,44 @@ module System.Process.Quick.CallSpec.Verify where  import Control.Monad.Writer.Strict hiding (lift)-import Data.Conduit ( runConduitRes, (.|) )-import Data.Conduit.Find as F-import Data.Conduit.List qualified as DCL-import Debug.TraceEmbrace+import Data.Map qualified as M+import Data.Multimap.Table (row, rowKeys, rowKeysSet)+import Data.Set (findMin)+import Data.Text.Lazy qualified as LT+import System.Process.Quick.CallSpec.Verify.ImportOverlook import Language.Haskell.TH.Syntax-import System.Directory-import System.Exit hiding (exitFailure)-import System.FilePath (getSearchPath, takeDirectory, takeExtension)-import System.IO.Temp (withSystemTempDirectory)-import System.Process (readProcessWithExitCode)-import System.Process.Quick.CallEffect import System.Process.Quick.CallSpec-import System.Process.Quick.Predicate-import System.Process.Quick.Predicate.InFile ()+import System.Process.Quick.CallSpec.Verify.Sandbox+import System.Process.Quick.CallSpec.Verify.TrailingHelp ( verifyTrailingHelp )+import System.Process.Quick.CallSpec.Verify.Type+import System.Process.Quick.Predicate (ArgCollector, RefinedInArgLocator(..), RefinedOutArgLocator(..)) import System.Process.Quick.Predicate.InDir ()+import System.Process.Quick.Predicate.InFile () import System.Process.Quick.Prelude hiding (Type, lift)---type FailureReport = Doc--data CallSpecViolation-  = HelpKeyIgnored-  | HelpKeyNotSupported FailureReport-  | ProgramNotFound FailureReport [FilePath]-  | HelpKeyExitNonZero FailureReport-  | SandboxLaunchFailed FailureReport-  | UnexpectedCallEffect [CallEffect]-  deriving (Show, Eq)--data CsViolationWithCtx-  = forall cs. CallSpec cs-  => CsViolationWithCtx-     { csContext :: cs-     , csViolation :: CallSpecViolation-     }--type M m = (MonadMask m, MonadCatch m, MonadIO m)+import System.Process.Quick.Prelude qualified as P+import System.Process.Quick.Util ( M )+import Text.Pretty.Simple  -callProcessSilently :: M m => FilePath -> [String] -> m (Maybe Doc)-callProcessSilently p args =-  tryIO (liftIO (readProcessWithExitCode p args "")) >>= \case-    Left e ->-      pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$-      "Failed due:" $$ tab e--    Right (ExitSuccess, _, _) -> pure Nothing-    Right (ExitFailure ec, out, err) ->-      pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$-      (if ec > 1 then "Exited with: " <> show ec $$ "" else "")-      <> out &! (("Output: " <+>) . tab) <> err &! (("StdErr: " <+>) . tab)- verifyWithActiveMethods ::-  forall w m cs. (M m, CallSpec cs, WriterT [FilePath] m ~ w) =>+  forall w m cs. (M m, CallSpec cs, WriterT [FilePath] (CsPerfT m) ~ w) =>   ArgCollector w ->   ArgCollector w ->   Set VerificationMethod ->   Proxy cs ->   Int ->-  m [CsViolationWithCtx]+  CsPerfT m [CsViolationWithCtx] verifyWithActiveMethods inArgLocators outArgLocators activeVerMethods pcs iterations =   catMaybes <$> mapM go  (filter (`member` activeVerMethods) (verificationMethods pcs))   where+    go :: VerificationMethod -> CsPerfT m (Maybe CsViolationWithCtx)     go = \case-      TrailingHelpValidate -> verifyTrailingHelp pcs iterations-      SandboxValidate -> validateInSandbox inArgLocators outArgLocators pcs iterations+      TrailingHelpValidate ->+        measureX pcs TrailingHelpValidate #csTotalTime $+          P.lift (verifyTrailingHelp pcs iterations)+      SandboxValidate ->+        measureX pcs SandboxValidate #csTotalTime $+          validateInSandbox inArgLocators outArgLocators (generate (arbitrary @cs)) iterations  -- |Compose a list of monadic actions into one action.  Composes using -- ('>=>') - that is, the output of each action is fed to the input of@@ -74,139 +46,89 @@ concatM :: (Monad m) => [a -> m a] -> (a -> m a) concatM fs = foldr (>=>) return fs -validateInSandbox ::-  forall w m cs. (M m, CallSpec cs, WriterT [FilePath] m ~ w) =>-  ArgCollector w ->-  ArgCollector w ->-  Proxy cs ->-  Int ->-  m (Maybe CsViolationWithCtx)-validateInSandbox inArgLocators outArgLocators pcs !iterations-  | iterations <= 0 = pure Nothing-  | otherwise =-    withSystemTempDirectory "quick-process" go >>= \case-      Nothing -> validateInSandbox inArgLocators outArgLocators pcs $ iterations - 1-      Just e -> pure $ Just e-  where-    checkFilesExist cs outFiles = do-      filterM (pure . not <=< doesFileExist) outFiles >>= \case-        [] -> pure Nothing-        ne -> pure . Just . CsViolationWithCtx cs $-          UnexpectedCallEffect-          [ FsEffect . FsAnd $ fmap (FsNot . flip FsPathPredicate [FsExists]) ne-          ]+formatPerfReportLine :: (TypeRep, CsPerf) -> Doc+formatPerfReportLine (typR, csp) =+  hsep [ fill 29 $ pretty typR+       , fill 15 . pretty . getSum $ csTotalTime csp+       -- , pretty $ (getSum (csExeTime csp <> csGenerationTime csp) `div` iterations+       , fill 15 . pretty . getSum $ csGenerationTime csp+       , fill 15 . pretty . getSum $ csExeTime csp+       ] -    findOriginFor projectDir inFile = do-      xs :: [FilePath] <- runConduitRes $-        F.find projectDir (do ignoreVcs-                              glob $ "*" <> takeExtension inFile-                              regular-                              not_ F.executable) .| DCL.consume-      case xs of-        [] -> pure Nothing-        neXs -> Just <$> generate (elements neXs)+reportFor :: MonadIO m => VerificationMethod -> CsPerfT m Doc+reportFor vm = do+  perfStats <- get+  pure $ tab (linebreak <+> "*** Method: " <+> pretty vm <> linebreak <>+       hsep [ fill 29 "Call Spec"+            , fill 15 "Total"+            , fill 15 "Generation"+            , fill 15 "Execution"+            ] $$+        "=======================================================================" $$+        (vcat . fmap formatPerfReportLine . reverse . sortWith (^. _2) . M.toList $ row vm perfStats)+      ) <> linebreak -    genInputFile projectDir inFile = (fromMaybe "/etc/hosts" <$> findOriginFor projectDir inFile) >>=-      \origin -> createDirectoryIfMissing True (takeDirectory inFile) >>-                 copyFile origin inFile-                 -- putStrLn ("File "  <> show origin <> " => " <> show inFile) -    doIn projectDir () = do-      cs <- liftIO (generate (arbitrary @cs))-      inFiles <- execWriterT (gmapM inArgLocators cs)-      -- absolute path is an issue for generator-      -- though process in docker is run under root - high chance to pass ;)-      -- quick hack is to use  odd size in Gen to avoid absolute path it Sandbox mode-      mapM_ (liftIO1 (genInputFile projectDir)) inFiles-      callProcessSilently (programName (pure cs)) (programArgs cs) >>= \case-        Nothing -> do-          outFiles <- execWriterT (gmapM outArgLocators cs)-          liftIO (checkFilesExist cs outFiles)-        Just e -> pure . Just . CsViolationWithCtx cs $ SandboxLaunchFailed e-    go tdp = do-      projectDir <- liftIO getCurrentDirectory-      bracket-        (liftIO $ setCurrentDirectory tdp)-        (\() -> liftIO $ setCurrentDirectory projectDir)-        (doIn projectDir)--verifyTrailingHelp ::-  forall m cs. (M m, CallSpec cs) =>-  Proxy cs ->-  Int ->-  m (Maybe CsViolationWithCtx)-verifyTrailingHelp pcs iterations =-  liftIO (findExecutable progName) >>= \case-    Nothing -> do-      cs <- genCs-      Just . CsViolationWithCtx cs . ProgramNotFound (text progName) <$> liftIO getSearchPath-    Just _ -> do-      spCmd progName helpKey-        (spCmd progName ("--hheellppaoesnthqkxsth" : helpKey)-           (do cs <- genCs-               pure . Just $ CsViolationWithCtx cs HelpKeyIgnored)-           (\_ -> go iterations))-        (\rep -> do-            cs <- genCs-            pure . Just . CsViolationWithCtx cs $ HelpKeyNotSupported rep)-  where-    progName = programName pcs-    genCs = liftIO (generate (arbitrary @cs))-    helpKey = ["--help"]-    spCmd pn args onSuccess onFailure = do-      liftIO $(trIo "spawn process/pn args")-      callProcessSilently pn args >>= \case-        Nothing -> onSuccess-        Just rep -> onFailure rep-    go n-      | n <= 0 = pure Nothing-      | otherwise = do-          cs <- liftIO (generate (arbitrary @cs))-          spCmd (programName pcs) (programArgs cs <> helpKey)-            (go $ n - 1)-            (\rep -> pure . Just . CsViolationWithCtx cs $ HelpKeyExitNonZero rep)-+consumeViolations :: MonadIO m => Int -> [CsViolationWithCtx] -> CsPerfT m ()+consumeViolations iterations = \case+  [] -> do+    perfStats <- get+    reports <- mapM reportFor $ rowKeys perfStats+    printDoc $ "All of" <+> pretty (M.size $ row (findMin $ rowKeysSet perfStats) perfStats)+      <+> "CallSpecs are valid due "+      <+> pretty iterations <+> "tests executed for each" <> fold reports -consumeViolations :: MonadIO m => [CsViolationWithCtx] -> m ()-consumeViolations = \case-  [] ->-    putStrLn "CallSpecs are valid"   vis -> do     let dashes = "-------------------------------------------------------------"     -- good case for hetftio ??-    printDoc $ "Error: quick-process found " <> doc (length vis) <> " failed call specs:"-      $$ (vcat $ zipWith (\i v -> tab ("-- [" <> doc i <> "] " <> dashes $$ printViolation v))+    printDoc $ "Error: quick-process found" <+> doc (length vis) <+> "failed call specs:"+      $$ (vcat $ zipWith (\i v -> tab ("-- [" <> doc i <> "]" <+> dashes $$ printViolation v))                  [1::Int ..] (sortByProgamName vis))-      <> "---------" <> dashes $$ "End of quick-process violation report"+      $$ "-------" <> dashes $$ "End of quick-process violation report" <> linebreak     exitFailure   where     sortByProgamName = sortWith (\(CsViolationWithCtx x _) -> programName $ pure x)     printViolation (CsViolationWithCtx cs v) =-      case v of-        HelpKeyIgnored -> (text . programName $ pure cs) <> ": help key ignored"-        ProgramNotFound report' pathCopy ->-          "[" <> (text . programName $ pure cs) <> "] is not found on PATH:" $$ tab (vsep pathCopy)-           $$ "Report:" $$ tab report' $$ ""-        HelpKeyNotSupported report' ->-          "--help key is not supported by [" <> (text . programName $ pure cs) <> "]"-          $$ "Report:" $$ tab report'-        HelpKeyExitNonZero rep ->-          (text . programName $ pure cs) <> " - non zero exit code:" $$ tab rep-        SandboxLaunchFailed rep ->-          (text . programName $ pure cs) <> " - non zero exit code:" $$ tab rep-        UnexpectedCallEffect uce -> do-          (text . programName $ pure cs) <> ": has unsafisfied effects:" $$ (text $ show uce)-           $$ "With arguments: " <> tab (programArgs cs)+      let pn = (text . toLazy . toText . programName $ pure cs) in+        case v of+          HelpKeyIgnored -> pn <> ": help key ignored"+          ProgramNotFound report' pathCopy ->+            "[" <> pn <> "] is not found on PATH:" $$ tab (vsep pathCopy)+             $$ "Report:" $$ tab report'+          HelpKeyNotSupported report' ->+            "--help key is not supported by [" <> pn <> "]"+            $$ "Report:" $$ tab report'+          HelpKeyExitNonZero rep ->+            pn <> " - non zero exit code:" $$ tab rep+          ExceptionThrown e ->+            "Launch of " <> pn <> " - thrown exception:" $$ tab (text $ show e)+            $$ "With arguments: " <> tab (programArgs cs)+          UnexpectedCallEffect uce -> do+            pn <> ": has unsafisfied effects:" $$ (vsep . fmap text . LT.lines $ pShow uce)+            $$ "With arguments: " <> tab (programArgs cs)  discoverAndVerifyCallSpecs :: Set VerificationMethod -> Int -> Q Exp discoverAndVerifyCallSpecs activeVerMethods iterations = do+  startedAt <- runIO currentTime   inArgLocators <- extractInstanceType <$> reifyInstances ''RefinedInArgLocator [VarT (mkName "b")]   when (inArgLocators == []) $ putStrLn "Discovered 0 InArg locators!!!"   outArgLocators <- extractInstanceType <$> reifyInstances ''RefinedOutArgLocator [VarT (mkName "c")]   when (outArgLocators == []) $ putStrLn "Discovered 0 OutArg locators!!!"   ts <- extractInstanceType <$> reifyInstances ''CallSpec [VarT (mkName "a")]-  when (ts == []) $ putStrLn "Discovered 0 types with CallSpec instance!!!"-  [| fmap concat (sequence $(ListE <$> (mapM (genCsVerification inArgLocators outArgLocators) ts))) >>= consumeViolations |]+  when (ts == []) $ fail "Discovered 0 types with CallSpec instance!!!"+  overlookedCss <- verifyFoundCsCoverCompiledOnes ts+  when (overlookedCss /= mempty) . fail . toString . displayT . renderOneLine $+    "Overlooked CallSpecs: " <> pretty overlookedCss+  !r <- [| void $ runStateT (+             fmap concat+               (sequence $(ListE <$> (mapM (genCsVerification+                                            inArgLocators outArgLocators) ts))) >>=+             consumeViolations $(lift iterations))+             mempty+        |]+  endedAt <- runIO currentTime+  putStrLn $ "discoverAndVerifyCallSpecs generation took " <> show (endedAt `diffUTCTime` startedAt)+  pure r   where     getLocator n t = AppE (VarE n) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) t))
+ src/System/Process/Quick/CallSpec/Verify/ImportOverlook.hs view
@@ -0,0 +1,29 @@+module System.Process.Quick.CallSpec.Verify.ImportOverlook+  ( addCompiledCallSpec+  , verifyFoundCsCoverCompiledOnes+  ) where++import Data.Set ( (\\), insert )+import Language.Haskell.TH ( Type, Name, nameModule, nameBase, mkName )+import System.Process.Quick.Prelude hiding (Type)+import System.Process.Quick.Util++erasePackage :: Type -> Type+erasePackage t = gmapT go t+  where+    go :: forall x. (Data x) => x -> x+    go x | Just Refl <- eqT @x @Name =+             mkName $ joinNe (fromMaybe "" $ nameModule x) '.' (nameBase x)+         | otherwise = x++compiledCallSpecs :: IORef (Set Type)+compiledCallSpecs = unsafePerformIO $ newIORef mempty++addCompiledCallSpec :: MonadIO m => Type -> m ()+addCompiledCallSpec xt = atomicModifyIORef'_ compiledCallSpecs $ $(tw "/") . insert (erasePackage xt)++verifyFoundCsCoverCompiledOnes :: MonadIO m => [Type] -> m (Set Type)+verifyFoundCsCoverCompiledOnes found =+  (\\ fromList found') <$> readIORef compiledCallSpecs+  where+    found' =  erasePackage <$> found
+ src/System/Process/Quick/CallSpec/Verify/Sandbox.hs view
@@ -0,0 +1,141 @@+module System.Process.Quick.CallSpec.Verify.Sandbox where++import Data.Conduit (runConduitRes, (.|))+import Data.Conduit.Find as F+import Data.Conduit.List qualified as DCL+import Data.Multimap.Table qualified as T+import System.Directory+import System.FilePath (takeDirectory, takeExtension)+import System.IO.Temp (withSystemTempDirectory)+import System.Process+import System.Process.Quick.CallEffect+import System.Process.Quick.CallSpec+import System.Process.Quick.CallSpec.Verify.Type+import System.Process.Quick.Predicate+import System.Process.Quick.Predicate.InDir ()+import System.Process.Quick.Predicate.InFile ()+import System.Process.Quick.Prelude hiding (Type, lift)+import System.Process.Quick.Util+++callProcessAndReport :: (CallSpec cs, M m) => cs -> m CsExecReport+callProcessAndReport cs = do+  proLaunchDir <- liftIO getCurrentDirectory+  startedAt <- currentTime+  liftIO (readProcessWithExitCode (programName (pure cs)) (programArgs cs) "") >>= \(ec, out, err) -> do+    endedAt <- currentTime+    pure CsExecReport+      { exitCode = ec+      , stdErr = err+      , stdOut = out+      , execTime = endedAt `diffUTCTime` startedAt+      , processDir = proLaunchDir+      }++normalizeOutcomeChecks :: CallSpec cs => cs -> [OutcomeChecker]+normalizeOutcomeChecks cs =+  case filter ecP origOutcomeChecks of+    [] -> ExitCodeEqualTo ExitSuccess : origOutcomeChecks+    [ExitCodeEqualTo ExitSuccess] ->+      $(tr "!ExitCodeEqualTo ExitSuccess check is redundant/cs")+        origOutcomeChecks+    [ExitCodeEqualTo _] -> origOutcomeChecks+    _ ->+      $(tr "!Multiple ExitCodeEqualTo checks/cs")+        origOutcomeChecks+  where+    origOutcomeChecks = outcomeCheckers cs+    ecP = \case ExitCodeEqualTo _ -> True ; _ -> False+++measureX :: forall m cs a. (Typeable cs, M m) =>+  Proxy cs -> VerificationMethod -> Lens' CsPerf (Sum NominalDiffTime) -> CsPerfT m a -> CsPerfT m a+measureX pcs vm l a = do+  started <- currentTime+  !r <- a+  ended <- currentTime+  modify' $ T.alter (merge ended started) vm (typeRep pcs)+  pure r+  where+    merge e s = pure . (l .~ (Sum $ e `diffUTCTime` s)) . fromMaybe mempty++validateInSandbox ::+  forall w m cs. (M m, CallSpec cs, WriterT [FilePath] (CsPerfT m) ~ w) =>+  ArgCollector w ->+  ArgCollector w ->+  (IO cs) ->+  Int ->+  CsPerfT m (Maybe CsViolationWithCtx)+validateInSandbox inArgLocators outArgLocators mkCs !iterations+  | iterations <= 0 = pure Nothing+  | otherwise =+      withSystemTempDirectory "quick-process" go >>= \case+        Nothing -> validateInSandbox inArgLocators outArgLocators mkCs $ iterations - 1+        Just e -> pure $ Just e+  where+    validateInit cs projectDir (CsBox h:initCss)+      = validateInSandboxOne projectDir inArgLocators outArgLocators (pure h) >>= \case+          Nothing -> validateInit cs projectDir initCss+          Just e -> pure $ Just e+    validateInit cs projectDir []+      = validateInSandboxOne projectDir inArgLocators outArgLocators (pure cs)+    doIn projectDir () = do+      cs <- liftIO mkCs+      validateInit cs projectDir =<< initCallSpecs cs+    go tdp = do+      projectDir <- liftIO getCurrentDirectory+      bracket+        (liftIO $ setCurrentDirectory tdp)+        (\() -> liftIO $ setCurrentDirectory projectDir)+        (doIn projectDir)+++validateInSandboxOne ::+  forall w m cs. (M m, CallSpec cs, WriterT [FilePath] (CsPerfT m) ~ w) =>+  FilePath ->+  ArgCollector w ->+  ArgCollector w ->+  (IO cs) ->+  CsPerfT m (Maybe CsViolationWithCtx)+validateInSandboxOne projectDir inArgLocators outArgLocators mkCs = doIn+  where+    checkFilesExist cs outFiles = do+      filterM (pure . not <=< doesFileExist) outFiles >>= \case+        [] -> pure Nothing+        ne -> pure . Just . CsViolationWithCtx cs $+          UnexpectedCallEffect+          [ FsEffect . FsAnd $ fmap (FsNot . flip FsPathPredicate [FsExists]) ne+          ]++    findOriginFor inFile = do+      xs :: [FilePath] <- runConduitRes $+        F.find projectDir (do ignoreVcs+                              glob $ "*" <> takeExtension inFile+                              regular+                              not_ F.executable) .| DCL.consume+      case xs of+        [] -> pure Nothing+        neXs -> Just <$> generate (elements neXs)++    genInputFile inFile = (fromMaybe "/etc/hosts" <$> findOriginFor inFile) >>=+      \origin -> createDirectoryIfMissing True (takeDirectory inFile) >>+                 copyFile origin inFile+                 -- putStrLn ("File "  <> show origin <> " => " <> show inFile)++    doIn = do+      let pcs = Proxy @cs+      cs <- measureX pcs SandboxValidate #csGenerationTime (liftIO mkCs)+      inFiles <- execWriterT (gmapM inArgLocators cs)+      -- absolute path is an issue for generator+      -- though process in docker is run under root - high chance to pass ;)+      -- quick hack is to use  odd size in Gen to avoid absolute path it Sandbox mode+      mapM_ (liftIO1 genInputFile) inFiles+      let nocs = normalizeOutcomeChecks cs+      tryIO (measureX pcs SandboxValidate #csExeTime $ callProcessAndReport cs) >>= \case+        Left e -> throw . CsViolationWithCtx cs . ExceptionThrown $ SomeException e+        Right csr -> mapM (check csr) nocs >>= pure . concat >>=+          \case+            [] -> do+              outFiles <- execWriterT (gmapM outArgLocators cs)+              liftIO (checkFilesExist cs outFiles)+            cfs -> pure . Just . CsViolationWithCtx cs $ UnexpectedCallEffect cfs
+ src/System/Process/Quick/CallSpec/Verify/TrailingHelp.hs view
@@ -0,0 +1,52 @@+module System.Process.Quick.CallSpec.Verify.TrailingHelp where+++import Debug.TraceEmbrace ( trIo )+import System.FilePath ( getSearchPath )+import System.Directory ( findExecutable )+import System.Process.Quick.CallSpec+    ( CallSpec(programArgs, programName) )+import System.Process.Quick.CallSpec.Verify.Type+    ( CsViolationWithCtx(CsViolationWithCtx),+      CallSpecViolation(HelpKeyNotSupported, HelpKeyExitNonZero,+                        ProgramNotFound, HelpKeyIgnored) )+import System.Process.Quick.Predicate.InDir ()+import System.Process.Quick.Predicate.InFile ()+import System.Process.Quick.Prelude hiding (Type, lift)+import System.Process.Quick.Util ( callProcessSilently, M )++verifyTrailingHelp ::+  forall m cs. (M m, CallSpec cs) =>+  Proxy cs ->+  Int ->+  m (Maybe CsViolationWithCtx)+verifyTrailingHelp pcs iterations =+  liftIO (findExecutable progName) >>= \case+    Nothing -> do+      cs <- genCs+      Just . CsViolationWithCtx cs . ProgramNotFound (text . toLazy $ toText progName) <$> liftIO getSearchPath+    Just _ -> do+      spCmd progName helpKey+        (spCmd progName ("--hheellppaoesnthqkxsth" : helpKey)+           (do cs <- genCs+               pure . Just $ CsViolationWithCtx cs HelpKeyIgnored)+           (\_ -> go iterations))+        (\rep -> do+            cs <- genCs+            pure . Just . CsViolationWithCtx cs $ HelpKeyNotSupported rep)+  where+    progName = programName pcs+    genCs = liftIO (generate (arbitrary @cs))+    helpKey = ["--help"]+    spCmd pn args onSuccess onFailure = do+      liftIO $(trIo "spawn process/pn args")+      callProcessSilently pn args >>= \case+        Nothing -> onSuccess+        Just rep -> onFailure rep+    go n+      | n <= 0 = pure Nothing+      | otherwise = do+          cs <- liftIO (generate (arbitrary @cs))+          spCmd (programName pcs) (programArgs cs <> helpKey)+            (go $ n - 1)+            (\rep -> pure . Just . CsViolationWithCtx cs $ HelpKeyExitNonZero rep)
+ src/System/Process/Quick/CallSpec/Verify/Type.hs view
@@ -0,0 +1,52 @@++module System.Process.Quick.CallSpec.Verify.Type where++import Data.Multimap.Table ( Table )+import Generic.Data ( gmappend, gmempty )+import Prelude (show)+import System.Process.Quick.CallEffect (CallEffect)+import System.Process.Quick.CallSpec.Type+import System.Process.Quick.Prelude hiding (show)++type FailureReport = Doc++data CallSpecViolation+  = HelpKeyIgnored+  | HelpKeyNotSupported FailureReport+  | ProgramNotFound FailureReport [FilePath]+  | HelpKeyExitNonZero FailureReport+  | ExceptionThrown SomeException+  | UnexpectedCallEffect [CallEffect]+  deriving (Show)++data CsViolationWithCtx+  = forall cs. CallSpec cs+  => CsViolationWithCtx+     { csContext :: cs+     , csViolation :: CallSpecViolation+     }++instance Show CsViolationWithCtx where+  show (CsViolationWithCtx cs csv) = "CsViolationWithCtx " <> show cs <> " " <> show csv++instance Exception CsViolationWithCtx+++data CsPerf+  = CsPerf+    { csGenerationTime :: !(Sum NominalDiffTime)+    , csTotalTime :: !(Sum NominalDiffTime)+    , csExeTime :: !(Sum NominalDiffTime)+    } deriving (Show, Eq, Generic)++instance Ord CsPerf where+  compare = comparing (^. #csTotalTime)++instance Semigroup CsPerf where+  (<>) = gmappend++instance Monoid CsPerf where+  mempty = gmempty+++type CsPerfT m = StateT (Table VerificationMethod TypeRep CsPerf) m
src/System/Process/Quick/Predicate/InDir.hs view
@@ -1,12 +1,10 @@ module System.Process.Quick.Predicate.InDir where -import Data.Typeable (eqT) import System.Directory import System.Process.Quick.Predicate import System.Process.Quick.Predicate.InFile ( genFilePathBy ) import System.Process.Quick.Prelude import Text.Regex.TDFA ((=~))-import Type.Reflection ((:~:)(Refl))  data InDir deriving (Data, Show, Eq, Generic)
src/System/Process/Quick/Predicate/InFile.hs view
@@ -1,6 +1,5 @@ module System.Process.Quick.Predicate.InFile where -import Control.Monad.Writer.Strict import System.Process.Quick.Predicate import System.Process.Quick.Prelude import System.Process.Quick.TdfaToSbvRegex as P@@ -8,8 +7,6 @@ import System.Process.Quick.CallArgument (NeList) import Text.Regex.TDFA ((=~)) import Type.Reflection qualified as R-import Type.Reflection ((:~:)(Refl))-import Data.Typeable (eqT)   data InFile (ext :: Symbol) deriving (Data, Show, Eq, Generic)
src/System/Process/Quick/Prelude.hs view
@@ -1,21 +1,29 @@ {-# OPTIONS_HADDOCK hide #-} module System.Process.Quick.Prelude (module M, liftIO1) where -import Control.Exception.Safe as M (MonadMask, MonadCatch, bracket, tryIO, try, tryAny)-import Data.Data as M (Data, gmapM)+import Control.Monad.Writer.Strict as M (MonadWriter (tell), WriterT, execWriterT)+import Control.Exception.Safe as M (MonadMask, MonadCatch, bracket, tryIO, try, tryAny, throw)+import Control.Lens as M (Lens', at, (^.), (.~), (%~), _1, _2)+import Control.Monad.Time as M (MonadTime(..)) import Data.Char as M (isAlphaNum, isAlpha, isLetter, isLower, toLower)+import Data.Data as M (Data, gmapM, gmapT)+import Data.Generics.Labels as M () import Data.HList as M (typeRep) import Data.List as M (isSuffixOf) import Data.Set as M (member)+import Data.Time.Clock as M (NominalDiffTime, diffUTCTime)+import Data.Typeable as M (TypeRep, eqT, (:~:) (Refl))+import Debug.TraceEmbrace as M (tr, tw) import Generic.Random as M (genericArbitraryU)+import GHC.TypeLits as M (Symbol, KnownSymbol (..), symbolVal)+import Refined as M (Refined, unrefine, refine, Predicate (..), throwRefineOtherException) import Relude as M hiding (Predicate) import Relude.Extra as M (toPairs)-import Test.QuickCheck as M (Gen, Arbitrary (..), generate, chooseInt, sized, elements, listOf)-import System.Process.Quick.Pretty as M-import System.Process as M (ProcessHandle, CreateProcess (..), readCreateProcess, readCreateProcessWithExitCode) import System.Exit as M (ExitCode (..))-import Refined as M (Refined, unrefine, refine, Predicate (..), throwRefineOtherException)-import GHC.TypeLits as M (Symbol, KnownSymbol (..), symbolVal)+import System.IO.Unsafe as M (unsafePerformIO)+import System.Process as M (ProcessHandle, CreateProcess (..), readCreateProcess, readCreateProcessWithExitCode)+import System.Process.Quick.Pretty as M+import Test.QuickCheck as M (Gen, Arbitrary (..), generate, chooseInt, sized, elements, listOf)  liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b liftIO1 = (.) liftIO
src/System/Process/Quick/Pretty.hs view
@@ -1,6 +1,10 @@+{-# OPTIONS_GHC -Wno-orphans #-} module System.Process.Quick.Pretty-  ( Pretty (..)+  ( doc+  , hsep -- Pretty (..)+  , vsep   , (&!)+  , ($$)   , escArg   , tab   , printDoc@@ -8,40 +12,36 @@   , module PP   ) where -import Control.Exception.Safe+import Data.Time ( NominalDiffTime )+import Control.Exception ( IOException )+import Data.Typeable import GHC.ResponseFile (escapeArgs) import Relude-import Text.PrettyPrint as PP hiding (hsep, (<>), empty, isEmpty)-import Text.PrettyPrint qualified as PP---class Pretty a where-  default doc :: Show a => a -> Doc-  doc = text . show-  doc :: a -> Doc+import Text.PrettyPrint.Leijen.Text as PP hiding ((<$>), bool, group, hsep, vsep, empty, isEmpty)+import Text.PrettyPrint.Leijen.Text qualified as PP+import Language.Haskell.TH qualified as TH+-- import Language.Haskell.TH.Syntax (Type (..)) -  hsep :: [a] -> Doc-  hsep = PP.hsep . fmap doc-  {-# INLINE hsep #-}+infixr 5 $$+($$) :: Doc -> Doc -> Doc+($$) = (<$$>) -  vsep :: [a] -> Doc-  vsep = vcat . fmap doc-  {-# INLINE vsep #-}+-- class Pretty a where+--   default doc :: Show a => a -> Doc+doc :: Pretty a => a -> Doc+doc = pretty --  . show+-- doc :: a -> Doc -instance Pretty Doc where-  doc = id-  {-# INLINE doc #-}-instance Pretty String where-  doc = text-  {-# INLINE doc #-}-instance Pretty IOException-instance Pretty Int-instance Pretty Integer-instance Pretty [String]+hsep :: Pretty a => [a] -> Doc+hsep = PP.hsep . fmap doc+{-# INLINE hsep #-} +vsep :: Pretty a => [a] -> Doc+vsep = vcat . fmap doc+{-# INLINE vsep #-} -printDoc :: MonadIO m => Doc -> m ()-printDoc = putStrLn . render+printDoc :: (MonadIO m, Pretty a) => a -> m ()+printDoc x = liftIO (putDoc $ pretty x)  tab :: Pretty a => a -> Doc tab = nest 2 . doc@@ -66,3 +66,23 @@  escArg :: String -> String escArg = reverse . drop 1 . reverse . escapeArgs . pure++instance Pretty IOException where+  pretty = text . show++instance Pretty TypeRep where+  pretty tr =+    let tc = typeRepTyCon tr in+      text . toLText $ tyConModule tc  <> "." <> tyConName tc++instance Pretty TH.Type where+  pretty = \case+    TH.ConT tn ->+      text . toLText . maybe (TH.nameBase tn) (<> "." <> TH.nameBase tn) $ TH.nameModule tn+    o -> text $ show o++instance Pretty a => Pretty (Set a) where+  pretty x = "{" <+> hsep (toList x) <+> "}"++instance Pretty NominalDiffTime where+  pretty = text . show
src/System/Process/Quick/Sbv/Arbitrary.hs view
@@ -1,10 +1,8 @@ module System.Process.Quick.Sbv.Arbitrary where  import System.Process.Quick.Prelude-import Data.SBV -- (Satisfiable, SymVal, Modelable (..), SString, sat, (.==), (.&&), literal)+import Data.SBV import Data.SBV.String qualified as S--- import Data.SBV.Control qualified as C-import System.IO.Unsafe (unsafePerformIO) import Data.SBV.RegExp  getSingleValue :: (SymVal b, Modelable m) => m -> Maybe b@@ -15,7 +13,6 @@       _ -> Nothing   | otherwise = Nothing --- models satOne :: (Satisfiable a, SymVal b) => Int -> a -> Maybe b satOne _n p = unsafePerformIO (getSingleValue <$> sat p) @@ -23,12 +20,6 @@ satN n p = unsafePerformIO (mapMaybe getSingleValue . allSatResults <$> asat)   where     asat = allSatWith defaultSMTCfg { allSatMaxModelCount = Just n } p---- satStateless :: SymVal a => Int -> a -> Symbolic (Either String b)--- satStateless seed p = unsafePerformIO go---   where---     solve ::---     go = runSMT solve  findStringByRegex :: (SymVal b) => RegExp -> Gen b findStringByRegex r = go (3 :: Int)
+ src/System/Process/Quick/Util.hs view
@@ -0,0 +1,25 @@+module System.Process.Quick.Util where++import Control.Monad.Writer.Strict hiding (lift)+import System.Exit hiding (exitFailure)+import System.Process+import System.Process.Quick.Prelude hiding (Type, lift)++type M m = (MonadTime m, MonadMask m, MonadCatch m, MonadIO m)++callProcessSilently :: M m => FilePath -> [String] -> m (Maybe Doc)+callProcessSilently p args =+  tryIO (liftIO (readProcessWithExitCode p args "")) >>= \case+    Left e ->+      pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$+      "Failed due:" $$ tab e++    Right (ExitSuccess, _, _) -> pure Nothing+    Right (ExitFailure ec, out, err) ->+      pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$+      (if ec > 1 then "Exited with: " <> show ec $$ "" else "")+      <> out &! (("Output: " <+>) . tab) <> err &! (("StdErr: " <+>) . tab)++joinNe :: [a] -> a -> [a] -> [a]+joinNe _ _ [] = []+joinNe p d s = p <> [d] <> s
test/System/Process/Quick/Test/Prelude.hs view
@@ -1,6 +1,6 @@ module System.Process.Quick.Test.Prelude (module M) where -import Control.Lens as M ((^.), (^?), at, ix)+import Control.Lens as M ((^?), ix) import Data.HList as M (HList(..), HExtend(..)) import Refined as M (SizeEqualTo) import System.Directory as M (doesFileExist, removeFile)
verify-call-specs/CallSpecs/Find.hs view
@@ -8,4 +8,7 @@  type DirPath = Refined FsPath String -$(genCallSpec [TrailingHelpValidate] "find" (ConstArg "-H" .*. VarArg @DirPath "path" .*. KeyArg @NodeType "-type" .*. HNil))+$(genCallSpec+  [TrailingHelpValidate]+  "find"+  (ConstArg "-H" .*. VarArg @DirPath "path" .*. KeyArg @NodeType "-type" .*. HNil))
verify-call-specs/CallSpecs/Find/Type.hs view
@@ -3,7 +3,7 @@ import System.Process.Quick import System.Process.Quick.Prelude -data NodeType = FileNode | DirNode deriving (Show, Eq, Generic, Typeable, Data)+data NodeType = FileNode | DirNode deriving (Show, Eq, Generic, Data)  instance Arbitrary NodeType where   arbitrary = genericArbitraryU