diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,235 @@ +20 Feb 2025 +0.5.4 Release +Merge Daniil's Itskov's changes: + Add files for building with nix + Build with ghc-9.10.1 +Remove tests for hCurry and hCompose where ghc-9.4.8 has poor type inference +not seen in newer versions. + +23 Sep 2023 +0.5.3 Release +Build with ghc-9.4.6 and ghc-9.6.1. +ghc-9.4.6 cannot compile examples/Properties/LengthIndependent.hs +as some types cannot be inferred. This is fixed in ghc-9.6.1. + +18 Feb 2022 +0.5.2 Release +Remove custom Setup.lhs which was for ghc-7.6 + +Change to pun quasiquote improves error messages: + For `f [pun| x y |] = ()` + f :: _ => r (a ': b ': c) -> () -- old + f :: _ => r as -> () -- new +Previously if you supplied a 9 element record to a function +needing 10 elements, the error would not name the missing field. +It is possible but unlikely that the old code will need to a type +annotation like +(id :: HLengthGE x (HSucc (HSucc HZero)) => r x -> r x) + +23 Oct 2021 +0.5.1 Release +Build & pass tests with ghc-8.4.4 through 9.2.0.20210821, +though with 9.2.0.20210821 dependencies for tests need +cabal flags --allow-newer=base --allow-newer=template-haskell, +and also invariant-functors and lens from git (as specified in `cabal.project`) + +Add examples/HListExample/OverloadedLabels.hs + +19 Feb 2018 +0.5.0 Release +Build & pass tests with ghc-7.6 through 8.4.0.20180209 + +Add Dredge.hs (ghc>=7.8): access nested records/variants given only the last +label along a path + +Move toLabel to another class to allow it to return Labels with +kinds other than Symbol. + +tipyLens can now change the element type + +Add hTake and hDrop + +Use TypeError for prettier error messages in ghc-8.0 (still backwards +compatible) + +Improve HFind and HUpdateAtHNat error messages by mentioning the whole +record being changed + +22 Dec 2015 +0.4.2 Release + +Depend on base-orphans to avoid multiple definitions of Typeable '[], +Typeable '(:) + +3 Aug 2015 +0.4.1 Release + +Add RecordU.hs, a record type with elements stored in unboxed arrays + +Documentation fixes (Thor Michael Støre) + +5 May 2015 +0.4 Release + +16 Apr 2015 +Make tests run (and pass) when called by "runghc Setup test" + +Add hNot, and add HNotFD which is injective (unlike the type family) + +Replace uses of `HLength xs ~ n` with `HLengthEq xs n`. + +15 Mar 2015 +Add HCurry.hs. + +Redefine Arity such that `Arity f (HSucc HZero)` will refine the +type of `f` to `x -> y`. + +SameLabels is generalized so that functions like 'asLabelsOf' do +not need to explicitly convert a that specifies the ordering of +labels. Additional constraints might be needed to restore the old +behavior: + +> type SameLabelsOld x y = (HAllTaggedLV x, HAllTaggedLV y, SameLabels x y) + +Similarly HExtend instances Proxy intended for making Proxies +used to disambiguate labels (see 'asLabelsOf' again). + +Add hMapOutV, zipVR, extendsVariant. Rename the previous +splitVariant to splitVariant1, and use the name splitVariant for +a function that splits a Variant into two Variants. + +Add projected to Labelable.hs which allows working on a smaller +Record or Variant. + +Add HasFieldM for lookups that return a default value if the +field is missing. + +Split HZip into two classes: class HUnzip r x y xy => HZip r x y xy. +This allows instance HUnzip Variant x y xy. + +Add Data,Typeable,Enum,Bounded,Ord,Monoid instances for Variant and TIC + +Implement HRLabelSet in terms of HLabelSet, which simplifies +inferred types that would otherwise have redundancy (HLabelSet +(LabelsOf r), HRLabelSet r) + +Move definitions into FakePrelude, and split up +examples/Properties.hs into separate modules to help with +compilation times when adding new tests. + +15 Feb 2015 +Change HList to a data family (see comments in HList.hs). + +Change the Show instance for TIP and HList to use "," not ", " as the +separator for consistency with Record and ordinary lists. + +Parameterize HZip over the collection type to work on Record, TIP as well as +HList. + +Add and use HProxies for building the spine of a HList from the type, to avoid +having HLists of undefined/error values somewhere. + +Build with ghc-7.10 RC1. RecordU/RecordUS is moved to broken/ instead of +updating it. + +9 Sep 2014 +Change the ordering of the list produced by HLeftUnion / (.<++.) +to better match hAppend / ++ suggested by the name. + +25 Aug 2014 +Add HSort, which provides a merge sort and a quick sort. + +Support _ (wildcard) with the pun quasiquoter, and make +patterns such as [pun| x y _ |] constrain the Record or Variant +to have at least 3 elements. + +Reduce the number of parameters for Labelable + +Allow operations with different label kinds (ie. +Record [Tagged 1 x, Tagged "y" Int]) to proceed as expected. + +13 Jul 2014 +Start RecordU and RecordUS, a variation on Record where the values +are stored in unboxed array(s). + +Add Partition, GroupBy and Span. + +Add list2HList and isos sameLength and sameLabels. + +23 Jun 2014 +TIPTransform and TIPTransformM become part of the distribution, +and missing fields are reported with the Fail superclass +technique. + +Projection of a TIP to a tuple is reimplemented without an explicit +type signature. The functions are exported as tipyTuple, +tipyTuple3 etc. + +Conversion between HLists and up to 6-tuples done with HTuple. + +Add ZipVariant, Unvariant, splitVariant, extendVariant, +an instance Eq (Variant v) and an instance Labelable TIC. + +Add quickcheck in examples/Properties.hs. Coverage measured with +HPC is about 40%. + +5 Jun 2014 +Start to parameterize operations on the collection type. This +means that where we previously had HMapCxt f x y another +type parameter with kind [*] -> * is added. This means +previous uses of HMapCxt f x y become HMap HList f x y. +This allows hMap to be used with Record and Variant. +HUpdateAtLabel is similarly generalized. + +Rework Variant: the implementation is now similar to Dynamic +and TIC. Likewise, TIP is implemented in terms of Record. + +28 May 2014 +Add tipyLens and ticPrism. + +Add a HExtend instance for Variant. + +Add functional dependencies to Labelable (and corresponding +superclasses) to avoid ambiguous types. + +26 May 2014 +Add prisms for Variant. This adds a dependency on "profunctors". + +Parameterize Labelable on the collection type. This allows +labelable labels to be used with RecordS or VariantS, where +the resulting Optic is a Lens or Prism respectively. + +Remove recordLabels in favor of labelsOf: a kind variable which +only appears on the RHS required a lengthy type annotation to fix +that variable. Pattern matching to convert a `Label (a :: k)` to +`a :: k` happens later on when another value with kind `k` is a +available on the LHS. + +Improve type errors when accessing missing fields when using +Labelable labels. Except for HPrism, the error message contains +`Fail (FieldNotFound "x")`. This involved adding a HUpdateAtLabel +class and HTPupdateAtLabel type which hides the `n` type +variable. + +Reduce the number of parameters to HMapCxt. The old version could +be defined in terms of the new version as: + + type HMapCxt_old f a b ha hb = (HMapCxt f a b, + HList a ~ ha, + HList b ~ hb) + +Reimplement RecordValues in terms of HMap. The original +implementation is kept because it avoids the need for +-XAllowAmbiguousTypes. + +Add hMapR and hMapV to map over the values in a Record or the +value in a Variant respectively. These functions are defined in +terms of HFmap which may be useful on it's own. + +Add a typeable instance for Label3, and change examples/cmdargs.hs +to use this label kind. This allows the example to work with +ghc-7.8.2 which lacks an instance Typeable (x :: Symbol). + 28 Mar 2014 Release 0.3.4.1 Fix build with ghc-7.8 broken by changes in HList 0.3.4 diff --git a/Data/HList/CommonMain.hs b/Data/HList/CommonMain.hs --- a/Data/HList/CommonMain.hs +++ b/Data/HList/CommonMain.hs @@ -11,43 +11,191 @@ module Data.HList.CommonMain ( + -- * Faking dependent types in Haskell module Data.HList.FakePrelude + + -- * Functions for all collections , module Data.HList.HListPrelude + -- * Array-like access to HLists , module Data.HList.HArray + -- * Result-type-driven operations , module Data.HList.HOccurs + -- * Type-indexed operations , module Data.HList.HTypeIndexed + + -- * Record , module Data.HList.Record + -- | quasiquoter 'pun' helps to avoid needing a proxy value with + -- type 'Label' in the first place: when you take values out of or into + -- records with pattern matching, the variable name determines the label + -- name. + , module Data.HList.RecordPuns + + -- ** Unpacked / Unboxed Records + , RecordU + , RecordUS + , SortForRecordUS(..) + , HUpdateMany(..) + , hMapRU + + -- *** internals for types + , HFindMany, HNats2Integrals(..) + + , RecordUSCxt + , HLookupByHNatUS, HLookupByHNatUS1 + , HSubtract, HMapUnboxF, UnboxF + , BoxF, EqTagValue, GetElemTy, ElemTyEq + , RecordToRecordU, RecordUToRecord + + -- * HList + -- | A subset of "Data.HList.HList" is re-exported. , module Data.HList.HList - , module Data.HList.TypeEqO - , module Data.HList.TIP - , module Data.HList.TIC , module Data.HList.HZip - , module Data.HList.Variant + -- ** A subset of "Data.HList.HSort" + , hSort + , HSort + , HSortBy(..) + , HLeFn, HDown + , HSet, HSetBy + , HIsSet, HIsSetBy + , HAscList, HIsAscList + -- ** A subset of "Data.HList.HCurry" + , HCurry'(..) + , hCurry, hUncurry + , hCompose + + -- * TIP + -- | Public interface of "Data.HList.TIP" + , TIP + , emptyTIP + , tipyUpdate + , tipyLens + , tipyLens' + -- ** projection + , tipyProject + , tipyProject2 + , tipyTuple + , tipyTuple3 + , tipyTuple4 + , tipyTuple5 + , TagUntag, TagUntagFD(..) + , TagR + + -- ** TIP transform + , TransTIP(..) + , TransTIPM(..) + + -- * TIC + -- | Public interface of "Data.HList.TIC" + , TIC + -- ** creating TIC + , mkTIC + , mkTIC1 + , mkTIC' + + -- ** get,set,modify + , ticPrism, ticPrism' + + -- * Variant + -- | Public interface of "Data.HList.Variant" + , Variant + , mkVariant + , mkVariant1 + , castVariant + , HMapV(..), hMapV + , hMapOutV + , ZipVariant(..) + , ZipVR(..), zipVR + -- ** projection + -- *** many + , SplitVariant(splitVariant) + , ProjectVariant(..) + , ExtendsVariant(..) + , ProjectExtendVariant(..) + -- *** one + , HPrism(..) + , unvarianted, unvarianted' + + , splitVariant1 + , splitVariant1' + , extendVariant + -- **** implementation + , Unvariant(..) + , Unvariant'(..) + + + + -- * Conversions between collections + -- $convention the foo' optic has the same type as + -- @Control.Lens.simple . foo . Control.Lens.simple@. + -- 'hLens'' is an exception to this rule. + + , TypeIndexed(..) + , typeIndexed' + -- ** HList and Record + -- | 'unlabeled' 'unlabeled'' + + -- ** HList and TIP + , tipHList, tipHList' + -- ** Record and RecordU + , unboxed, unboxed' + -- ** Record and RecordUS + , unboxedS, unboxedS' + -- ** Record and Variant + , hMaybied, hMaybied' + + -- ** Newtype wrappers + -- $convention these isos unwrap/wrap the newtypes 'TIP' 'TIC' and + -- 'Record'. Names follow the pattern @fromTo :: Iso' From To@. + + -- | 'hListRecord' 'hListRecord'' are exported under "Data.HList.Record" + , ticVariant, ticVariant' + , tipRecord, tipRecord' + + -- *** implementation + , VariantToHMaybied(variantToHMaybied) + , HMaybiedToVariantFs + , hMaybiedToVariants + -- * "Data.HList.Keyword" -- | the \"public\" parts. More examples are in the module documentation. , Kw(..), recToKW, IsKeyFN, K, ErrReqdArgNotFound, ErrUnexpectedKW -- * Labels - {- | there are really only two options for now, but there are - a couple different styles for the first option here: - - GHC supports type-level strings ('GHC.TypeLits.Symbol'), and these can be - labels. You can refer to these strings using an unwieldy syntax. For - example if you want to store a value @5@ in a record @rec@ with a field - called @\"x\"@, and then get it out again: + {- | By labels, we mean either the first argument to 'Tagged' (in the + type-level lists that are supplied to 'Record', 'RecordU', 'TIP', 'TIC'), + or the expressions used to specify those types to be able to look up + the correct value in those collections. - let rec = ('Label' :: Label \"x\") '.=.' 5 '.*.' 'emptyRecord' + Nearly all types can be labels. For example: - rec '.!.' (Label :: Label \"x\") + @ + r :: Record '[Tagged "x" Int, -- kind GHC.TypeLits.Symbol + Tagged () (), -- see "Data.HList.Label5" + Tagged (Lbl HZero LabelUniverse LabelMember1) () -- Label3 + ] + r = 'hBuild' 8 () () -- don't need to use '.=.' / '.==.' and '.*.' + -- if we have a type signature above + @ + + we could define these variables - To avoid that pain, you can have a definition @x = Label :: Label "x"@. - and just use @x@ instead of repeating @Label :: Label \"x\"@ so that - a lookup becomes: + @ + xLabel = Label :: Label \"x\" -- 'makeLabels6' ["x"] would define x with the same RHS + xLens = hLens' xLabel -- 'makeLabelable' "x" would define x with the same RHS + @ - > rec .!. x + to access the @8@ given above: - See 'makeLabels6' for automating the @x = Label :: Label \"x\"@. + @ + r '.!.' xLabel + r ^. xLens -- alternatively Control.Lens.view + r ^. `x -- with HListPP is used (not in ghci), + -- which avoids the issue of conflicting + -- definitions of x, which mean the same + -- thing + @ -} -- $label6demo @@ -55,21 +203,34 @@ , module Data.HList.Labelable -- $labelable + -- ** "Data.HList.Dredge" + -- *** lenses + , dredge, dredge' + , dredgeND, dredgeND' + , dredgeTI' + -- *** plain lookup + , hLookupByLabelDredge, HasFieldPath + -- ** namespaced labels , module Data.HList.Label3 - -- | template haskell for automating different types of labels + -- ** labels as any instance of Typeable + -- | "Data.HList.Label5" + + -- ** template haskell , module Data.HList.MakeLabels - -- | quasiquoter 'pun' helps to avoid needing a proxy value with - -- type 'Label' in the first place: when you take values out of or into - -- records with pattern matching, the variable name determines the label - -- name. - , module Data.HList.RecordPuns -- * "Data.HList.Data" -- | This modules provide useful instances. A useful application can be -- found in @examples/cmdargs.hs@ + + -- | Overlapping instances are restricted to here + , module Data.HList.TypeEqO + + -- * Internals + -- | internals exported for type signature purposes + , HAllTaggedEq ) where import Data.HList.FakePrelude @@ -78,16 +239,31 @@ import Data.HList.HOccurs import Data.HList.HTypeIndexed import Data.HList.Record -import Data.HList.HList +-- import Data.HList.RecordOrd +import Data.HList.HList hiding (append', + hAppend', + FHCons(..), + hMapAux, + MapCar(..), + hMapMapCar, + hSequence2, + ) +import Data.HList.HCurry +import Data.HList.HSort import Data.HList.MakeLabels -import Data.HList.TypeEqO +import Data.HList.TypeEqO hiding (IsKeyFN) import Data.HList.TIP import Data.HList.TIC import Data.HList.HZip -import Data.HList.Label3 +import Data.HList.Label3 hiding (MapLabel) +import Data.HList.Label5 () -- only instances import Data.HList.Label6 () -- only instances -import Data.HList.Labelable +import Data.HList.Labelable (Labelable(..), + Projected(..), projected', + toLabel, + (.==.), + LabeledOptic) import Data.HList.Variant @@ -95,7 +271,10 @@ import Data.HList.Keyword import Data.HList.RecordPuns +import Data.HList.RecordU +import Data.HList.Dredge + {- $label6demo #label6demo# Instances from "Data.HList.Label6" @@ -114,12 +293,14 @@ {- $labelable #labelabledemo# Rather than having the @x = Label :: Label \"x\"@, the labels -generated by 'makeLabelable' also double lenses for "Control.Lens". +generated by 'makeLabelable' also double as lenses for "Control.Lens". Here is an example of how much better that is: >>> :set -XNoMonomorphismRestriction -XDataKinds -XPolyKinds >>> import Control.Lens +>>> import Data.HList.Labelable >>> let x = hLens' (Label :: Label "x") +>>> let y = hLens' (Label :: Label "y") The Label6 method: @@ -137,6 +318,13 @@ >>> r & x .~ () Record{x=()} + +When a field is missing, the error names that field: + +>>> :t r^.y +... +...No instance for (Fail (FieldNotFound "y")) +... -} diff --git a/Data/HList/Data.hs b/Data/HList/Data.hs --- a/Data/HList/Data.hs +++ b/Data/HList/Data.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} -{- | 'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend +{- | Description: Data instances + + +'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend to be flat data structures. The @Data@ instance for 'HList' gives a nested structure. -NOTE: these instances do not work with ghc-7.8 because of - +NOTE: these instances do not work with ghc-7.8 with promoted +string (Symbol) labels because of + [@HList@] @@ -48,50 +52,57 @@ -- * exports for type signatures/ haddock usage DataHListFlatCxt, DataRecordCxt, - TypeRepsList, + TypeRepsList(..), -- ** less likely to be used RecordLabelsStr(..), GfoldlK(..), GunfoldK(..), HListFlat(..), + TypeablePolyK, ) where import Data.HList.FakePrelude import Data.HList.HList import Data.HList.Record -import GHC.TypeLits +import Data.HList.Variant import Data.Data -import Data.List -import GHC.Exts (Constraint) - -import Unsafe.Coerce +import Data.HList.TIC +import Data.HList.TIP +-- for Typeable '[] and Typeable '(:) with ghc-7.6 +import Data.Orphans () -instance (Data x, Data (HList xs), Typeable (HList (x ': xs)), - TypeablePolyK (x ': xs)) - => Data (HList (x ': xs)) where - gfoldl k z (HCons a b) = (z HCons `k` a) `k` b - gunfold k z _ = k (k (z HCons)) +#if OLD_TYPEABLE +import Data.List +#endif - dataTypeOf _ = hListDataRep - toConstr _ = hConsConRep +import Unsafe.Coerce -instance (TypeablePolyK ('[] :: [*])) => Data (HList '[]) where - gfoldl _k z HNil = z HNil - gunfold _k z _ = z HNil - dataTypeOf _ = hListDataRep - toConstr _ = hNilConRep +deriving instance Typeable (HList '[]) => Data (HList '[]) +deriving instance + (Data x, + Data (HList xs), + TypeablePolyK (x ': xs), -- for new typeable + Typeable (HList (x ': xs) -- for old typeable + )) => Data (HList (x ': xs)) -hListDataRep = mkDataType "Data.HList.HList" [hConsConRep, hNilConRep] -hConsConRep = mkConstr hListDataRep "HCons" [] Prefix -hNilConRep = mkConstr hListDataRep "HNil" [] Prefix +deriving instance + (TypeablePolyK xs, + Typeable (HList xs), + Data (HList xs)) => Data (TIP xs) +deriving instance + (TypeablePolyK xs, + Typeable (Variant xs), + Data (Variant xs)) => Data (TIC xs) -- | this data type only exists to have Data instance newtype HListFlat a = HListFlat (HList a) -type DataHListFlatCxt g a = (HBuild' '[] g, +type DataHListFlatCxt na g a = ( + g ~ FoldRArrow a (HList a), + HBuild' '[] g, Typeable (HListFlat a), TypeablePolyK a, HFoldl (GfoldlK C) (C g) a (C (HList a)), @@ -99,12 +110,28 @@ HFoldr (GunfoldK C) (C g) - (HReplicateR (HLength a) ()) + (HReplicateR na ()) (C (HList a)), - HReplicate (HLength a) ()) + HLengthEq a na, + HReplicate na ()) -instance DataHListFlatCxt g a => Data (HListFlat a) where + +-- | ghc-8.0.2 can't work out the type g, +-- in the 2nd argument of gfoldl. ghc <= 7.10 +-- don't need it. +-- +-- in `instance Data (HListFlat '[a,b,c])` +-- +-- > g ~ (a -> b -> c -> HList '[a,b,c]) +-- > g ~ GetG '[a,b,c] (HList '[a,b,c]) +type family FoldRArrow (xs :: [*]) (r :: *) + +type instance FoldRArrow '[] r = r +type instance FoldRArrow (x ': xs) r = x -> FoldRArrow xs r + + +instance DataHListFlatCxt na g a => Data (HListFlat a) where gfoldl k z (HListFlat xs) = c3 $ hFoldl (c1 (GfoldlK k)) @@ -182,7 +209,7 @@ recordLabelsStr _ = [] instance (RecordLabelsStr xs, ShowLabel x) => RecordLabelsStr (Tagged x t ': xs) where - recordLabelsStr _ = showLabel (undefined :: Label x) : + recordLabelsStr _ = showLabel (Label :: Label x) : recordLabelsStr (undefined :: Record xs) {- | @@ -202,8 +229,8 @@ recordLabelsStr2 _ = [] instance (RecordLabelsStr2 xs, ShowLabel x) => RecordLabelsStr2 (x ': xs) where - recordLabelsStr2 _ = showLabel (undefined :: Label x) : - recordLabelsStr2 (undefined :: proxy xs) + recordLabelsStr2 _ = showLabel (Label :: Label x) : + recordLabelsStr2 (Proxy :: Proxy xs) -- | use only with @instance Data (HList a)@. This is because the HFoldl @@ -212,13 +239,18 @@ data C a -- typeable isntances... either hand written or derived when possible -#if MIN_VERSION_base(4,7,0) +#if !OLD_TYPEABLE deriving instance Typeable Record deriving instance Typeable HList deriving instance Typeable HListFlat --- deriving instance Typeable Tagged +deriving instance Typeable Variant +deriving instance Typeable TIC +deriving instance Typeable TIP -type TypeablePolyK (a :: k) = (Typeable a) +-- orphans +deriving instance Typeable 'HZero +deriving instance Typeable 'HSucc + #else instance TypeRepsList (Record xs) => Typeable (HList xs) where typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.HList" "HList") @@ -228,48 +260,59 @@ typeOf x = mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "Record") [ tyConList (typeRepsList x) ] +instance TypeRepsList (Record xs) => Typeable (Variant xs) where + typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Variant" "Variant") + [ tyConList (typeRepsList (error "Data.HList.Data:Typeable Variant" :: Record xs)) ] + +instance Typeable (Variant xs) => Typeable (TIC xs) where + typeOf (TIC xs) = mkTyConApp (mkTyCon3 "HList" "Data.HList.TIC" "TIC") + [typeOf xs] + +instance Typeable (HList xs) => Typeable (TIP xs) where + typeOf (TIP xs) = mkTyConApp (mkTyCon3 "HList" "Data.HList.TIP" "TIP") + [typeOf xs] + instance ShowLabel sy => Typeable1 (Tagged sy) where typeOf1 _ = mkTyConApp - (mkTyCon3 "HList" "Data.HList.Data" (showLabel (undefined :: Label sy))) + (mkTyCon3 "HList" "Data.HList.Data" (showLabel (Label :: Label sy))) [] instance (ShowLabel sy, Typeable x) => Typeable (Tagged sy x) where typeOf _ = mkTyConApp - (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (undefined :: Label sy))) + (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label sy))) [mkTyConApp (mkTyCon3 "HList" "Data.HList.Record" "=") [], - typeOf (undefined :: x) + typeOf (error "Data.HList.Data:Typeable Tagged" :: x) ] -type TypeablePolyK a = (() :: Constraint) - instance Typeable (HList a) => Typeable (HListFlat a) where typeOf _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Data" "HListFlat") [typeOf (error "Typeable HListFlat" :: HList a)] -#endif - - -- pretty-prints sort of like a real list tyConList xs = mkTyConApp open ( intersperse comma xs ++ [close] ) where open = mkTyCon3 "GHC" "GHC.TypeLits" "[" close = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" "]") [] comma = mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" ",") [] +#endif + + + class TypeRepsList a where typeRepsList :: a -> [TypeRep] -instance (TypeRepsList (Prime xs), ConvHList xs) => TypeRepsList (Record xs) where - typeRepsList (Record xs) = typeRepsList (prime xs) +instance (TypeRepsList (HList xs)) => TypeRepsList (Record xs) where + typeRepsList (Record xs) = typeRepsList xs -instance (TypeRepsList xs, Typeable x) => TypeRepsList (HCons' x xs) where - typeRepsList (~(x `HCons'` xs)) +instance (TypeRepsList (HList xs), Typeable x) => TypeRepsList (HList (x ': xs)) where + typeRepsList (~(x `HCons` xs)) = typeOf x : typeRepsList xs -instance TypeRepsList HNil' where +instance TypeRepsList (HList '[]) where typeRepsList _ = [] diff --git a/Data/HList/Dredge.hs b/Data/HList/Dredge.hs new file mode 100644 --- /dev/null +++ b/Data/HList/Dredge.hs @@ -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) + + diff --git a/Data/HList/FakePrelude.hs b/Data/HList/FakePrelude.hs --- a/Data/HList/FakePrelude.hs +++ b/Data/HList/FakePrelude.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE OverlappingInstances #-} --- just for the proxy +{-# LANGUAGE CPP #-} {- | The HList library @@ -11,31 +10,77 @@ module Data.HList.FakePrelude (module Data.HList.FakePrelude, - module Data.Proxy) where + -- * re-exports + module Data.Proxy, + module Data.Tagged, + Monoid(..), + Any) where import Data.Proxy -import GHC.Prim (Constraint) +import Data.Tagged +import GHC.Exts (Constraint,Any) import GHC.TypeLits +#if __GLASGOW_HASKELL__ >= 800 +import qualified GHC.TypeLits as Data.HList.FakePrelude (ErrorMessage((:$$:), (:<>:))) -- XXX check this works? +#endif +#if __GLASGOW_HASKELL__ <= 906 +import Control.Applicative +#endif +#if NEW_TYPE_EQ +import Data.Type.Equality (type (==)) +#endif +#if !OLD_TYPEABLE +import Data.Typeable +#endif + +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid (Monoid(..)) +#endif + + -- -------------------------------------------------------------------------- -- * A heterogeneous apply operator -- | simpler/weaker version where type information only propagates forward --- with this one. 'app' defined below, is more complicated / verbose to define, +-- with this one. 'applyAB' defined below, is more complicated / verbose to define, -- but it offers better type inference. Most uses have been converted to --- 'app', so there is not much that can be done with 'Apply'. +-- 'applyAB', so there is not much that can be done with 'Apply'. class Apply f a where type ApplyR f a :: * apply :: f -> a -> ApplyR f a - apply = undefined -- In case we use Apply for - -- type-level computations only {- $note - Polymorphic functions are not first-class in haskell. One solution is to - write an instance of 'ApplyAB' for a data type that takes the place of - the original function. In other words, + Polymorphic functions are not first-class in haskell. An example of this + is: + > f op = (op (1 :: Double), op (1 :: Int)) + + [@RankNTypes@] + + One solution is to enable `-XRankNTypes` and then write a type + signature which might be `f :: (forall a. Num a => a -> a)`. This + does not work in the context of HList, since we want to use functions + that do not necessarily fall into the pattern of (forall a. c a => a -> a). + + [@MultipleArguments@] + + Another solution is to rewrite @op@ to look like + + > f op1 op2 = (op1 (1:: Double), op2 (1 :: Int)) + + In some sense this approach works (see HZip), but the result + is constrained to as many function applications as you are willing to + write (ex. a function that works for records of six entries would + look like @hBuild f f f f f f@). + + + [@Defunctionalization@] + + Therefore the selected solution is to write an instance of 'ApplyAB' for a data + type that takes the place of the original function. In other words, + > data Fn = Fn > instance ApplyAB Fn a b where applyAB Fn a = actual_fn a @@ -56,15 +101,54 @@ The first instance allows types to be inferred as if we had @class ApplyAB a b c | a -> b c@, while the second instance only matches if ghc already knows that it needs - @ApplyAB Fn Int Double@. Additional explanation can be found + @ApplyAB Fn Int Double@. Since @applyAB Fn :: Int -> Double@ + has a monomorphic type, this trimmed down example does not + really make sense because @applyAB (fromIntegral :: Int -> Double)@ + is exactly the same. Nontheless, the other uses of @ApplyAB@ + follow this pattern, and the benefits are seen when the type of + @applyAB Fn@ has at least one type variable. + + Additional explanation can be found in + + [@AmbiguousTypes@] + + Note that ghc only allows AllowAmbiguousTypes when a type + signature is provided. Thus expressions such as: + + > data AddJust = AddJust + > instance (y ~ Maybe x) => ApplyAB AddJust x y where + > applyAB _ x = Just x + > + > twoJustsBad = hMap AddJust . hMap AddJust -- ambiguous type + + Are not accepted without a type signature that references the + intermediate \"b\": + + > twoJusts :: forall r a b c. (HMapCxt r AddJust a b, HMapCxt r AddJust b c) => + > r a -> r c + > twoJusts a = hMap AddJust (hMap AddJust a :: r b) + + An apply class with functional dependencies + + > class ApplyAB' f a b | f a -> b, f b -> a + + Or with equivalent type families + + > class (GetB f a ~ b, GetA f b ~ a) => ApplyAB' f a b + + would not require an annotation for @twoJusts@. However, + not all instances of ApplyAB will satisfy those functional + dependencies, and thus the number of classes would proliferate. + Furthermore, inference does not have to be in one direction + only, as the example of 'Data.HList.HList.HMap' shows. + -} -- | No constraints on result and argument types class ApplyAB f a b where applyAB :: f -> a -> b - applyAB = undefined -- In case we use Apply for type-level computations only {- $fun @@ -84,10 +168,15 @@ constraints on the argument type: >>> :set -XDataKinds - >>> let plus1 = Fun (\x -> if x < 5 then x+1 else 5) :: Fun '[Num, Ord] '() + >>> let plus1f x = if x < 5 then x+1 else 5 + >>> let plus1 = Fun plus1f :: Fun '[Num, Ord] '() >>> :t applyAB plus1 - applyAB plus1 :: (Num a, Ord a) => a -> a + applyAB plus1 :: (Num b, Ord b) => b -> b + >>> let xs = [1 .. 8] + >>> map (applyAB plus1) xs == map plus1f xs + True + Also note the use of @'()@ to signal that the result type is the same as the argument type. @@ -96,7 +185,7 @@ >>> let succ1 = Fun succ :: Fun Enum '() >>> :t applyAB succ1 - applyAB succ1 :: Enum a => a -> a + applyAB succ1 :: Enum b => b -> b >>> let just = Fun Just :: Fun '[] Maybe @@ -203,7 +292,7 @@ -} data HComp g f = HComp g f -- ^ @g . f@ -instance forall f g a b c. (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where +instance (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where applyAB ~(HComp g f) x = applyAB g (applyAB f x :: b) @@ -230,7 +319,7 @@ -- | (\(a,b) -> f a >> b) newtype HSeq x = HSeq x -instance (Monad m, ApplyAB f x fx, fx ~ m (), pair ~ (x,m ()), +instance (Monad m, ApplyAB f x fx, fx ~ m (), pair ~ (x,m ()), ApplyAB f x (m ()) ) => ApplyAB (HSeq f) pair fx where applyAB (HSeq f) (x,c) = do asVoid (applyAB f x); c where asVoid :: m () -> m () @@ -249,17 +338,45 @@ instance (f1 ~ (a -> b -> c), f2 ~ (b -> a -> c)) => ApplyAB HFlip f1 f2 where applyAB _ = flip + +-- | 'fmap' +newtype HFmap f = HFmap f + +instance (x ~ t a, + y ~ t b, + Functor t, + ApplyAB f a b) => + ApplyAB (HFmap f) x y where + applyAB (HFmap f) = fmap (applyAB f) + + +-- | 'liftA2' +newtype LiftA2 f = LiftA2 f + +instance (ApplyAB f (x,y) z, + mz ~ m z, + mxy ~ (m x, m y), + Applicative m) => ApplyAB (LiftA2 f) mxy mz where + applyAB (LiftA2 f) xy = liftA2 (curry (applyAB f)) `uncurry` xy + + +-- | 'untag' +data HUntag = HUntag +instance (Tagged t x ~ tx) => ApplyAB HUntag tx x where + applyAB _ (Tagged x) = x + + -- -------------------------------------------------------------------------- -- * Proxy -- --- $note see "Data.HList.Proxy" +-- $note see "Data.Proxy" -- | A special 'Proxy' for record labels, polykinded data Label l = Label labelToProxy :: Label l -> Proxy l -labelToProxy = undefined +labelToProxy _ = Proxy class ShowLabel l where showLabel :: Label l -> String @@ -290,11 +407,8 @@ -} -- ** Value-level proxies -hTrue :: Proxy True ; hTrue = undefined -hFalse :: Proxy False; hFalse = undefined - -instance Show (Proxy True) where show _ = "HTrue" -instance Show (Proxy False) where show _ = "HFalse" +hTrue :: Proxy True ; hTrue = Proxy +hFalse :: Proxy False; hFalse = Proxy -- ** Conjunction @@ -305,7 +419,7 @@ -- | `demote' to values hAnd :: Proxy t1 -> Proxy t2 -> Proxy (HAnd t1 t2) -hAnd = undefined +hAnd _ _ = Proxy -- ** Disjunction @@ -316,7 +430,7 @@ -- | `demote' to values hOr :: Proxy t1 -> Proxy t2 -> Proxy (HOr t1 t2) -hOr = undefined +hOr _ _ = Proxy {- $boolHistoricalNote @@ -343,7 +457,19 @@ > hOr _ _ = hTrue -} +type family HNot (x :: Bool) :: Bool +type instance HNot True = False +type instance HNot False = True +-- | as compared with 'HNot' this version is injective +class HNotFD (b :: Bool) (nb :: Bool) | b -> nb, nb -> b +instance HNotFD True False +instance HNotFD False True + +hNot :: HNotFD a notA => Proxy a -> Proxy notA +hNot _ = Proxy + + class HCond (t :: Bool) x y z | t x y -> z where hCond :: Proxy t -> x -> y -> z @@ -376,23 +502,51 @@ data HNat = HZero | HSucc HNat -hZero :: Proxy HZero; hZero = undefined -hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = undefined -hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = undefined +hZero :: Proxy HZero; hZero = Proxy +hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = Proxy +hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = Proxy class HNat2Integral (n::HNat) where hNat2Integral :: Integral i => Proxy n -> i +type family HNat2Nat (n :: HNat) :: Nat +type instance HNat2Nat HZero = 0 +type instance HNat2Nat (HSucc n) = 1 + HNat2Nat n + +#if MIN_VERSION_base(4,7,0) +{- Instead convert HNat to GHC.TypeLits.'Nat' with 'HNat2Nat' and use functions +from that module to produce the 'Integer' -} +instance KnownNat (HNat2Nat n) => HNat2Integral n where + hNat2Integral _ = fromIntegral (natVal (Proxy :: Proxy (HNat2Nat n))) +#else +{- doesn't work: gives "No instance for (SingI Nat (1 + (1 + 0)))" +instance SingI (HNat2Nat n) => HNat2Integral n where + hNat2Integral _ = fromIntegral (fromSing (sing :: Sing (HNat2Nat n))) +-} + +-- | a slow (at runtime) implementation for ghc 7.6: instance HNat2Integral HZero where hNat2Integral _ = 0 instance HNat2Integral n => HNat2Integral (HSucc n) where hNat2Integral n = hNat2Integral (hPred n) + 1 +#endif -instance HNat2Integral n => Show (Proxy (n :: HNat)) where - show n = "H" ++ show (hNat2Integral n :: Integer) +class HNats2Integrals (ns :: [HNat]) where + hNats2Integrals :: Integral i => Proxy ns -> [i] +instance HNats2Integrals '[] where + hNats2Integrals _ = [] + +instance (HNats2Integrals ns, + HNat2Integral n) + => HNats2Integrals (n ': ns) where + hNats2Integrals _ = hNat2Integral (Proxy :: Proxy n) : + hNats2Integrals (Proxy :: Proxy ns) + + + -- | Equality on natural numbers -- (eventually to be subsumed by the universal polykinded HEq) type family HNatEq (t1 :: HNat) (t2 :: HNat) :: Bool @@ -412,9 +566,26 @@ type instance HLt (HSucc n) (HSucc n') = HLt n n' hLt :: Proxy x -> Proxy y -> Proxy (HLt x y) -hLt = undefined +hLt _ _ = Proxy +-- | Less than or equal to +type family HLe (x :: HNat) (y :: HNat) :: Bool + +type instance HLe HZero HZero = True +type instance HLe (HSucc x) y = HLt x y + +hLe :: Proxy x -> Proxy y -> Proxy (HLe x y) +hLe _ _ = Proxy + +-- | @HDiv2 x@ behaves like @x `div` 2@ +type family HDiv2 (x :: HNat) :: HNat +type instance HDiv2 HZero = HZero +type instance HDiv2 (HSucc HZero) = HZero +type instance HDiv2 (HSucc (HSucc a)) = HSucc (HDiv2 a) + + + -- -------------------------------------------------------------------------- -- * Maybies -- $maybiesNote We cannot use lifted Maybe since the latter are not populated @@ -430,17 +601,49 @@ -- for the sake of the generic equality. class HEq (x :: k) (y :: k) (b :: Bool) | x y -> b --- Equality instances for naturals +-- | Equality for types that may have different kinds. This definition +-- allows operations on @Record [Tagged \"x\" a, Tagged 2 b]@ to work +-- as expected. +type HEqK (x :: k1) (y :: k2) (b :: Bool) = HEq (Proxy x) (Proxy y) b -instance HEq HZero HZero True -instance HEq HZero (HSucc n) False -instance HEq (HSucc n) HZero False -instance HEq n n' b => HEq (HSucc n) (HSucc n') b +#if NEW_TYPE_EQ +-- | Uses @(==) :: * -> * -> Bool@ because +-- there is no polykinded instance of (==), +-- since that one overlaps "more productive" +-- instances that pattern match on types. +instance ((Proxy x == Proxy y) ~ b) => HEq x y b +#endif hEq :: HEq x y b => x -> y -> Proxy b -hEq = undefined +hEq _ _ = Proxy +-- | this class generalizes HEq by allowing the choice of @f@ to allow +-- equating only part of x and y +class HEqByFn f => HEqBy (f :: t) (x :: k) (y :: k) (b :: Bool) | f x y -> b + + + + +-- | Every instance of this class should have an instance of 'HEqBy' +class HEqByFn f + +-- * Arity + +type Arity f n = (ArityFwd f n, ArityRev f n) + +-- | calculate the number of arguments a function can take +class ArityFwd (f :: *) (n :: HNat) | f -> n + + +-- | given the number of arguments a function can take, make sure +-- the function type actually matches +class ArityRev (f :: *) (n :: HNat) -- n -> f -- if we had -XDysfunctionalDependencies + +instance ArityRev f HZero +instance (xf ~ (x -> f), ArityRev f n) => ArityRev xf (HSucc n) + + -- -------------------------------------------------------------------------- -- * Staged equality @@ -451,50 +654,178 @@ -- * Establish remaining value-level equality dynamically -- -- removed: use typeable -{- -class HStagedEq x y - where - hStagedEq :: x -> y -> Bool --} +-- -------------------------------------------------------------------------- +-- * Type-safe cast -- no longer need. We use a a ~ b -{- + +-- * Cast + +-- | Named after 'Data.Typeable.cast', which behaves the same at runtime. +-- One difference is that there is a HCast instance for every type, while +-- 'Typeable' instances can be missing sometimes. + +class HCast x y where + hCast :: x -> Maybe y + +instance (HEq x y b, HCast1 b x y) => HCast x y where + hCast = hCast1 (Proxy :: Proxy b) + +-- | helper for 'HCast' +class HCast1 (b :: Bool) x y where + hCast1 :: Proxy b -> x -> Maybe y + +instance (x ~ y) => HCast1 True x y where + hCast1 _ x = Just x + +instance HCast1 False x y where + hCast1 _ _ = Nothing + + + + -- -------------------------------------------------------------------------- --- | A predicate for type equality +-- * Error messages + +{- | A class without instances for explicit failure. + +Note that with ghc>=8.0, `x :: TypeError` which is formatted properly. +Otherwise `x` is made of nested (left-associated) promoted tuples. +For example: + +> (x ~ '( '( '("the", Int), "is wrong") ) ) :: ((,) Symbol *, Symbol) + +Therefore code that works across ghc-7.6 through ghc-8.0 needs to +use ErrText, ErrShowType, :<>:, :$$: to construct the type x. -} +class Fail (x :: k) + +#if __GLASGOW_HASKELL__ >= 800 +-- | use the alias ErrText to prevent conflicts with Data.Text -- --- There are different implementations: see TypeEq*.hs +-- GHC.TypeLits.:<>: and GHC.TypeLits.:$$: are re-exported +type ErrText x = GHC.TypeLits.Text x +type ErrShowType x = GHC.TypeLits.ShowType x -class HBool b => TypeEq x y b | x y -> b +-- type Fail = TypeError -- another option +instance TypeError x => Fail x +#else +type ErrText x = x +type ErrShowType x = x +type x :<>: y = '(x,y) +type x :$$: y = '(x,y) +infixl 6 :<>: +infixl 5 :$$: +#endif --- Rely on lazy show for type-level Booleans -typeEq :: TypeEq t t' b => t -> t' -> b -typeEq = undefined +-- ** Error messages used elsewhere +type FieldNotFound key collection = ErrText "key" :<>: ErrShowType key + :$$: ErrText "could not be found in" :<>: ErrShowType collection +type ExcessFieldFound key collection = ErrText "found field" :<>: ErrShowType key + :$$: ErrText "when it should be absent from" :<>: ErrShowType collection --- A more disciplined version: based on proxies -proxyEq :: TypeEq t t' b => Proxy t -> Proxy t' -> b -proxyEq _ _ = undefined +type HNatIndexTooLarge (nat :: HNat) (r :: [k] -> *) (xs :: [k]) = + ErrText "0-based index" :<>: ErrShowType (HNat2Nat nat) :<>: + ErrText "is too large for collection" + :$$: ErrShowType (r xs) + -- :$$: ErrText "(length: " :<>: ErrShowType (HNat2Nat (HLength collection)) :<>: ErrText " )" + -- Data.HList.HList.HLength isn't available here +type ExtraField x = ErrText "extra field" :<>: ErrShowType x + + +#if OLD_TYPEABLE +type TypeablePolyK a = (() :: Constraint) +#else +type TypeablePolyK (a :: k) = Typeable a +#endif + +-- * Constraining Lists +-- ** Length + +-- | Ensure two lists have the same length. We do case analysis on the +-- first one (hence the type must be known to the type checker). +-- In contrast, the second list may be a type variable. +class SameLength' (es1 :: [k]) (es2 :: [m]) +instance (es2 ~ '[]) => SameLength' '[] es2 +instance (SameLength' xs ys, es2 ~ (y ': ys)) => SameLength' (x ': xs) es2 + +{- | symmetrical version of 'SameLength''. Written as a class instead of + + > type SameLength a b = (SameLength' a b, SameLength' b a) + +since ghc expands type synonyms, but not classes (and it seems to have the same +result) + -} +class (SameLength' x y, SameLength' y x) => + SameLength (x :: [k]) (y :: [m]) where --- -------------------------------------------------------------------------- --- * Type-safe cast -- no longer need. We use a a ~ b + {- | @SameLength x y => Equality (r x) (q y) (r x) (q y)@ -{- -class TypeCast x y | x -> y, y -> x - where - typeCast :: x -> y + used like 'Control.Lens.simple', except it restricts + the type-level lists involved to have the same length, + without fixing the type of container or the elements + in the list. + -} + sameLength :: r x `p` f (q y) -> r x `p` f (q y) + sameLength = id + +-- | 'asTypeOf' +asLengthOf :: SameLength x y => r x -> s y -> r x +asLengthOf = const + + +instance (SameLength' x y, SameLength' y x) => SameLength x y + +type family SameLengths (xs :: [[k]]) :: Constraint +type instance SameLengths (x ': y ': ys) = (SameLength x y, SameLengths (y ': ys)) +type instance SameLengths '[] = () +type instance SameLengths '[x] = () + +-- ** Labels + +class SameLabels (x :: k) (y :: m) + +{- | @sameLabels@ constrains the type of an optic, such that the labels + (@t@ in @Tagged t a@) are the same. @x@ or @y@ may have more elements + than the other, in which case the elements at the end + of the longer list do not have their labels constrained. + + see also 'sameLength' -} +sameLabels :: SameLabels x y => p (r x) (f (q y)) -> p (r x) (f (q y)) +sameLabels = id +-- instances for [*] kind +instance SameLabels '[] '[] +instance SameLabels '[] (x ': xs) +instance SameLabels (x ': xs) '[] +instance (SameLabels x y, SameLabels xs ys) => + SameLabels (x ': xs) (y ': ys) --- -------------------------------------------------------------------------- --- * Error messages +instance (Label t ~ Label t') => SameLabels (Label t) (Tagged t' a) +instance (Label t ~ Label t') => SameLabels (Label t) (Label t') +instance (Label t ~ Label t') => SameLabels (Label t) (t' :: Symbol) --- | A class without instances for explicit failure -class Fail x +instance SameLabels (Label t) s => SameLabels (t :: Symbol) s +instance SameLabels (Label t) s => SameLabels (Tagged t a) s +-- ** A list has only Tagged values +-- | The 'Record', 'Variant', 'TIP', 'TIC' type constructors only make +-- sense when they are applied to an instance of this class +class HAllTaggedLV (ps :: [*]) +instance HAllTaggedLV '[] +instance (HAllTaggedLV xs, x ~ Tagged t v) => HAllTaggedLV (x ': xs) + + +-- | see Data.HList.Record.'zipTagged' +type family ZipTagged (ts :: [k]) (vs :: [*]) :: [*] +type instance ZipTagged (Label t ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs +type instance ZipTagged ((t :: Symbol) ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs +type instance ZipTagged '[] '[] = '[] diff --git a/Data/HList/HArray.hs b/Data/HList/HArray.hs --- a/Data/HList/HArray.hs +++ b/Data/HList/HArray.hs @@ -47,19 +47,27 @@ -- -------------------------------------------------------------------------- -- * Update +class HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where + hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) -class HUpdateAtHNat (n :: HNat) e (l :: [*]) where +instance HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where + hUpdateAtHNat = hUpdateAtHNat' (Proxy :: Proxy l) + +class HUpdateAtHNat' (n :: HNat) e (l :: [*]) (l0 :: [*]) where type HUpdateAtHNatR (n :: HNat) e (l :: [*]) :: [*] - hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) + hUpdateAtHNat' :: Proxy l0 -> Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) -instance HUpdateAtHNat HZero e1 (e ': l) where +instance HUpdateAtHNat' HZero e1 (e ': l) l0 where type HUpdateAtHNatR HZero e1 (e ': l) = e1 ': l - hUpdateAtHNat _ e1 (HCons _ l) = HCons e1 l + hUpdateAtHNat' _ _ e1 (HCons _ l) = HCons e1 l -instance HUpdateAtHNat n e1 l => HUpdateAtHNat (HSucc n) e1 (e ': l) where +instance HUpdateAtHNat' n e1 l l0 => HUpdateAtHNat' (HSucc n) e1 (e ': l) l0 where type HUpdateAtHNatR (HSucc n) e1 (e ': l) = e ': (HUpdateAtHNatR n e1 l) - hUpdateAtHNat n e1 (HCons e l) = HCons e (hUpdateAtHNat (hPred n) e1 l) + hUpdateAtHNat' l0 n e1 (HCons e l) = HCons e (hUpdateAtHNat' l0 (hPred n) e1 l) +instance Fail (HNatIndexTooLarge n HList l0) => HUpdateAtHNat' n e1 '[] l0 where + type HUpdateAtHNatR n e1 '[] = '[] + hUpdateAtHNat' _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances" -- -------------------------------------------------------------------------- -- * Projection @@ -70,7 +78,7 @@ newtype FHLookupByHNat (l :: [*]) = FHLookupByHNat (HList l) -instance HLookupByHNat n l => +instance HLookupByHNat n l => Apply (FHLookupByHNat l) (Proxy (n :: HNat)) where type ApplyR (FHLookupByHNat l) (Proxy n) = HLookupByHNatR n l apply (FHLookupByHNat l) n = hLookupByHNat n l @@ -80,7 +88,7 @@ -- repeated traversals of the HList l at run-time. -- Here is a more optimal version with a better separation of --- compile-time and run-time computation. +-- compile-time and run-time computation. -- The list of labels to project is type-level only. -- We treat this list of labels as a set -- that is, we will -- ignore duplicates. @@ -90,11 +98,11 @@ -- We unify hProjectByHNats and hProjectAwayByHNats in one -- function, distinguished by the sel :: Bool in -- FHUProj below. The operation hProjectByHNats corresponds --- to sel = True (that is, elements of l whose indices are found in +-- to sel = True (that is, elements of l whose indices are found in -- ns are to be included in the result), whereas hProjectByHNats -- corresponds to set = False. -hProjectByHNats (_ :: Proxy (ns :: [HNat])) l = +hProjectByHNats (_ :: Proxy (ns :: [HNat])) l = hUnfold (FHUProj :: FHUProj True ns) (l,hZero) data FHUProj (sel :: Bool) (ns :: [HNat]) = FHUProj @@ -103,25 +111,25 @@ type ApplyR (FHUProj sel ns) (HList '[],n) = HNothing apply _ _ = HNothing -instance (ch ~ Proxy (HBoolEQ sel (KMember n ns)), - Apply (ch, FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat))) => +instance (ch ~ Proxy (HBoolEQ sel (KMember n ns)), + Apply (ch, FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat))) => Apply (FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat)) where - type ApplyR (FHUProj sel ns) (HList (e ': l),Proxy n) = + type ApplyR (FHUProj sel ns) (HList (e ': l),Proxy n) = ApplyR (Proxy (HBoolEQ sel (KMember n ns)), FHUProj sel ns) - (HList (e ': l),Proxy n) - apply fn s = apply (undefined::ch,fn) s + (HList (e ': l),Proxy n) + apply fn s = apply (Proxy::ch,fn) s -instance Apply (Proxy True, FHUProj sel ns) +instance Apply (Proxy True, FHUProj sel ns) (HList (e ': l),Proxy (n::HNat)) where - type ApplyR (Proxy True, FHUProj sel ns) (HList (e ': l),Proxy n) = - (HJust (e, (HList l,Proxy (HSucc n)))) + type ApplyR (Proxy True, FHUProj sel ns) (HList (e ': l),Proxy n) = + (HJust (e, (HList l,Proxy (HSucc n)))) apply _ (HCons e l,n) = (HJust (e,(l,hSucc n))) instance (Apply (FHUProj sel ns) (HList l, Proxy (HSucc n))) => - Apply (Proxy False, FHUProj sel ns) + Apply (Proxy False, FHUProj sel ns) (HList (e ': l),Proxy (n::HNat)) where - type ApplyR (Proxy False, FHUProj sel ns) (HList (e ': l),Proxy n) = - ApplyR (FHUProj sel ns) (HList l, Proxy (HSucc n)) + type ApplyR (Proxy False, FHUProj sel ns) (HList (e ': l),Proxy n) = + ApplyR (FHUProj sel ns) (HList l, Proxy (HSucc n)) apply (_,fn) (HCons _ l,n) = apply fn (l,hSucc n) @@ -131,13 +139,14 @@ type instance KMember n (n1 ': l) = HOr (HNatEq n n1) (KMember n l) -- Useful abbreviations for complex types (which are inferred) -type HProjectByHNatsR (ns :: [HNat]) (l :: [*]) = +type HProjectByHNatsR (ns :: [HNat]) (l :: [*]) = HUnfold (FHUProj True ns) (HList l, Proxy 'HZero) type HProjectByHNatsCtx ns l = (Apply (FHUProj True ns) (HList l, Proxy 'HZero), - HUnfold' (FHUProj True ns) - (ApplyR (FHUProj True ns) (HList l, Proxy 'HZero))) + HUnfold' (FHUProj True ns) + (HList l, Proxy 'HZero) + ) -- * Complement of Projection @@ -146,20 +155,20 @@ -- Instead, we compute the complement of indices to project away -- to obtain the indices to project to, and then use hProjectByHNats. -- Only the latter requires run-time computation. The rest --- are done at compile-time only. +-- are done at compile-time only. -hProjectAwayByHNats (_ :: Proxy (ns :: [HNat])) l = +hProjectAwayByHNats (_ :: Proxy (ns :: [HNat])) l = hUnfold (FHUProj :: FHUProj False ns) (l,hZero) -- Useful abbreviations for complex types (which are inferred) -type HProjectAwayByHNatsR (ns :: [HNat]) (l :: [*]) = +type HProjectAwayByHNatsR (ns :: [HNat]) (l :: [*]) = HUnfold (FHUProj False ns) (HList l, Proxy 'HZero) type HProjectAwayByHNatsCtx ns l = (Apply (FHUProj False ns) (HList l, Proxy 'HZero), - HUnfold' (FHUProj False ns) (ApplyR (FHUProj False ns) - (HList l, Proxy 'HZero))) + HUnfold' (FHUProj False ns) (HList l, Proxy 'HZero) + ) -- * Splitting -- | Splitting an array according to indices @@ -167,7 +176,7 @@ -- The following is not optimal; we'll optimize later if needed hSplitByHNats ns l = (hProjectByHNats ns l, - hProjectAwayByHNats ns l) + hProjectAwayByHNats ns l) {- hSplitByHNats ns l = hSplitByHNats' ns (hFlag l) diff --git a/Data/HList/HCurry.hs b/Data/HList/HCurry.hs new file mode 100644 --- /dev/null +++ b/Data/HList/HCurry.hs @@ -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 + +-} +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 diff --git a/Data/HList/HList.hs b/Data/HList/HList.hs --- a/Data/HList/HList.hs +++ b/Data/HList/HList.hs @@ -1,1037 +1,1657 @@ -{- | - The HList library - - (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke - - Basic declarations for typeful heterogeneous lists. - - Excuse the unstructured haddocks: while there are many declarations here - some are alternative implementations should be grouped, and the definitions - here are analgous to many list functions in the "Prelude". - -} - -module Data.HList.HList where - -import Data.HList.FakePrelude -import Data.HList.HListPrelude - -import Control.Applicative (Applicative, liftA2, pure) - - --- -------------------------------------------------------------------------- --- * Heterogeneous type sequences --- $note --- --- The easiest way to ensure that sequences can only be formed with Nil --- and Cons is to use GADTs --- The kind [*] is list kind (lists lifted to types) - -data HList (l::[*]) where - HNil :: HList '[] - HCons :: e -> HList l -> HList (e ': l) - --- | this comparison is two traversals -instance (ConvHList l, Eq (Prime l)) => Eq (HList l) where - x == y = prime x == prime y - --- ** Alternative representation -{- $note - -HNil' and HCons' are the older ADT-style. This has some advantages -over the GADT: - -* lazy pattern matches are allowed - -* type inference is better if you want to directly pattern match - - --} -data HNil' = HNil' deriving (Eq) -data HCons' a b = HCons' a b deriving (Eq) - - --- | conversion between GADT ('HList') and ADT ('HNil'' 'HCons'') --- representations -class (UnPrime (Prime a) ~ a) => ConvHList (a :: [*]) where - type Prime a :: * - type UnPrime b :: [*] - prime :: HList a -> Prime a - unPrime :: Prime a -> HList a - -instance ConvHList as => ConvHList (a ': as) where - type Prime (a ': as) = a `HCons'` Prime as - type UnPrime (b `HCons'` bs) = (b ': UnPrime bs) - prime (a `HCons` as) = a `HCons'` prime as - unPrime ~(a `HCons'` as) = a `HCons` unPrime as - -instance ConvHList '[] where - type Prime '[] = HNil' - type UnPrime HNil' = '[] - prime _ = HNil' - unPrime _ = HNil - - - - -instance Show (HList '[]) where - show _ = "H[]" - -instance (Show e, Show (HList l)) => Show (HList (e ': l)) where - show (HCons x l) = let 'H':'[':s = show l - in "H[" ++ show x ++ - (if s == "]" then s else ", " ++ s) - -infixr 2 `HCons` - - --- -------------------------------------------------------------------------- --- * Basic list functions - --- | 'head' -hHead :: HList (e ': l) -> e -hHead (HCons x _) = x - --- | 'tail' -hTail :: HList (e ': l) -> HList l -hTail (HCons _ l) = l - --- | Length -type family HLength (x :: [k]) :: HNat -type instance HLength '[] = HZero -type instance HLength (x ': xs) = HSucc (HLength xs) - -hLength :: HList l -> Proxy (HLength l) -hLength _ = undefined - --- ** Append -instance HExtend e (HList l) where - type HExtendR e (HList l) = HList (e ': l) - (.*.) = HCons - -instance HAppend (HList l1) (HList l2) where - hAppend = hAppendList -type instance HAppendR (HList l1) (HList l2) = HList (HAppendList l1 l2) - -type family HAppendList (l1 :: [k]) (l2 :: [k]) :: [k] -type instance HAppendList '[] l = l -type instance HAppendList (e ': l) l' = e ': HAppendList l l' - --- | the same as 'hAppend' -hAppendList :: HList l1 -> HList l2 -> HList (HAppendList l1 l2) -hAppendList HNil l = l -hAppendList (HCons x l) l' = HCons x (hAppend l l') - --- -------------------------------------------------------------------------- - --- ** Alternative append - - --- | 'hAppend'' below is implemented using the same idea -append' :: [a] -> [a] -> [a] -append' l l' = foldr (:) l' l - --- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr' -hAppend' :: (HFoldr FHCons v l r) => HList l -> v -> r -hAppend' l l' = hFoldr FHCons l' l - -data FHCons = FHCons - -instance ( x ~ (e,HList l), y ~ (HList (e ': l))) => ApplyAB FHCons x y where - applyAB _ (e,l) = HCons e l - - --- ** Historical append - -{- $ - -The original HList code is included below. In both cases -we had to program the algorithm twice, at the term and the type levels. - -[@The class HAppend@] - -> class HAppend l l' l'' | l l' -> l'' -> where -> hAppend :: l -> l' -> l'' -> - -[@The instance following the normal append@] - -> instance HList l => HAppend HNil l l -> where -> hAppend HNil l = l -> -> instance (HList l, HAppend l l' l'') -> => HAppend (HCons x l) l' (HCons x l'') -> where -> hAppend (HCons x l) l' = HCons x (hAppend l l') - --} - --- -------------------------------------------------------------------------- --- * Reversing HLists - --- Append the reversed l1 to l2 -type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k] -type instance HRevApp '[] l = l -type instance HRevApp (e ': l) l' = HRevApp l (e ': l') - -hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2) -hRevApp HNil l = l -hRevApp (HCons x l) l' = hRevApp l (HCons x l') - -hReverse l = hRevApp l HNil - - - --- -------------------------------------------------------------------------- - --- --- * A nicer notation for lists --- - - --- | List termination -hEnd :: HList l -> HList l -hEnd = id - -{- ^ - Note: - - [@x :: HList a@] means: @forall a. x :: HList a@ - - [@hEnd x@] means: @exists a. x :: HList a@ --} - - --- | Building lists - -hBuild :: (HBuild' '[] r) => r -hBuild = hBuild' HNil - -class HBuild' l r where - hBuild' :: HList l -> r - -instance (l' ~ HRevApp l '[]) - => HBuild' l (HList l') where - hBuild' l = hReverse l - -instance HBuild' (a ': l) r - => HBuild' l (a->r) where - hBuild' l x = hBuild' (HCons x l) - --- ** examples -{- $examplesNote - -The classes above allow the third (shortest) way to make a list -(containing a,b,c) in this case - -> list = a `HCons` b `HCons` c `HCons` HNil -> list = a .*. b .*. c .*. HNil -> list = hEnd $ hBuild a b c - ->>> let x = hBuild True in hEnd x -H[True] - ->>> let x = hBuild True 'a' in hEnd x -H[True, 'a'] - ->>> let x = hBuild True 'a' "ok" in hEnd x -H[True, 'a', "ok"] - --} - --- *** historical -{- $hbuild the show instance has since changed, but these uses of -'hBuild'/'hEnd' still work - -> HList> let x = hBuild True in hEnd x -> HCons True HNil - -> HList> let x = hBuild True 'a' in hEnd x -> HCons True (HCons 'a' HNil) - -> HList> let x = hBuild True 'a' "ok" in hEnd x -> HCons True (HCons 'a' (HCons "ok" HNil)) - -> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) -> HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil))) - -> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus -> True - --} - --- -------------------------------------------------------------------------- - --- * folds --- ** foldr --- $foldNote Consume a heterogenous list. GADTs and type-classes mix well - - -class HFoldr f v (l :: [*]) r where - hFoldr :: f -> v -> HList l -> r - -instance (v ~ v') => HFoldr f v '[] v' where - hFoldr _ v _ = v - --- | uses 'ApplyAB' not 'Apply' -instance (ApplyAB f (e, r) r', HFoldr f v l r) - => HFoldr f v (e ': l) r' where - hFoldr f v (HCons x l) = applyAB f (x, hFoldr f v l :: r) - - -class HScanr f z ls rs where - hScanr :: f -> z -> HList ls -> HList rs - -instance HScanr f z '[] '[z] where - hScanr _ z _ = HCons z HNil - -instance (ApplyAB f (x,r) s, HScanr f z xs (r ': rs)) => HScanr f z (x ': xs) (s ': r ': rs) where - hScanr f z (HCons x xs) = - case hScanr f z xs :: HList (r ': rs) of - HCons r rs -> (applyAB f (x,r) :: s) `HCons` r `HCons` rs - -class HFoldr1 f (l :: [*]) r where - hFoldr1 :: f -> HList l -> r - -instance (v ~ v') => HFoldr1 f '[v] v' where - hFoldr1 _ (HCons v _) = v - --- | uses 'ApplyAB' not 'Apply' -instance (ApplyAB f (e, r) r', HFoldr1 f (e' ': l) r) - => HFoldr1 f (e ': e' ': l) r' where - hFoldr1 f (HCons x l) = applyAB f (x, hFoldr1 f l :: r) - - --- ** foldl - -{- | like 'foldl' - - ->>> hFoldl (uncurry $ flip (:)) [] (1 `HCons` 2 `HCons` HNil) -[2,1] - - --} -class HFoldl f (z :: *) xs (r :: *) where - hFoldl :: f -> z -> HList xs -> r - -instance forall f z z' r x zx xs. (zx ~ (z,x), ApplyAB f zx z', HFoldl f z' xs r) - => HFoldl f z (x ': xs) r where - hFoldl f z (x `HCons` xs) = hFoldl f (applyAB f (z,x) :: z') xs - -instance (z ~ z') => HFoldl f z '[] z' where - hFoldl _ z _ = z - - - - - --- * unfold --- $unfoldNote Produce a heterogenous list. Uses the more limited --- 'Apply' instead of 'App' since that's all that is needed for uses of this --- function downstream. Those could in principle be re-written. - -hUnfold :: (Apply p s, HUnfold' p (ApplyR p s)) => p -> s -> HList (HUnfold p s) -hUnfold p s = hUnfold' p (apply p s) - -type HUnfold p s = HUnfoldR p (ApplyR p s) - -class HUnfold' p res where - type HUnfoldR p res :: [*] - hUnfold' :: p -> res -> HList (HUnfoldR p res) - -instance HUnfold' p HNothing where - type HUnfoldR p HNothing = '[] - hUnfold' _ _ = HNil - -instance (Apply p s, HUnfold' p (ApplyR p s)) => HUnfold' p (HJust (e,s)) where - type HUnfoldR p (HJust (e,s)) = e ': HUnfold p s - hUnfold' p (HJust (e,s)) = HCons e (hUnfold p s) - - --- * replicate - -class (HLength (HReplicateR n e) ~ n) => - HReplicate (n :: HNat) e where - hReplicate :: Proxy n -> e -> HList (HReplicateR n e) - -instance HReplicate HZero e where - hReplicate _ _ = HNil - -instance HReplicate n e => HReplicate (HSucc n) e where - hReplicate n e = e `HCons` hReplicate (hPred n) e - --- | would be associated with 'HReplicate' except we want --- it to work with `e` of any kind, not just `*` that you can --- put into a HList. An \"inverse\" of 'HLength' -type family HReplicateR (n :: HNat) (e :: k) :: [k] -type instance HReplicateR HZero e = '[] -type instance HReplicateR (HSucc n) e = e ': HReplicateR n e - --- * concat - -{- | - -Like 'concat' but for HLists of HLists. - -Works in ghci... puzzling as what is different in doctest (it isn't -@-XExtendedDefaultRules@) - -> hConcat $ hBuild (hBuild 1 2 3) (hBuild 'a' "abc") - -H[1, 2, 3, 'a', "abc"] - - --} -class HConcat (a :: [*]) where - type HConcatR a :: [*] - hConcat :: HList a -> HList (HConcatR a) - -instance HConcat '[] where - type HConcatR '[] = '[] - hConcat _ = HNil - -instance (x ~ HList t, HConcat xs) => HConcat (x ': xs) where - type HConcatR (x ': xs) = HAppendList (UnHList x) (HConcatR xs) - hConcat (x `HCons` xs) = x `hAppendList` hConcat xs - - -type family UnHList a :: [*] -type instance UnHList (HList a) = a - --- -------------------------------------------------------------------------- --- * traversing HLists - --- ** producing HList --- *** map --- $mapNote It could be implemented with 'hFoldr', as we show further below - -{- | hMap is written such that the length of the result list -can be determined from the length of the argument list (and -the other way around). Similarly, the type of the elements -of the list is propagated in both directions too. - -Excuse the ugly types printed. Unfortunately ghc (still?) -shows types like @'[a,b]@ using the actual constructors involved -@(':) a ((':) b '[])@ (or even worse when the kind variables are printed). - ->>> :set -XNoMonomorphismRestriction ->>> let xs = 1 .*. 'c' .*. HNil ->>> :t hMap (HJust ()) xs -hMap (HJust ()) xs - :: Num y => HList ((':) * (HJust y) ((':) * (HJust Char) ('[] *))) - - -These 4 examples show that the constraint on the length (2 in this cae) -can be applied before or after the 'hMap'. That inference is independent of the -direction that type information is propagated for the individual elements. - - ->>> let asLen2 xs = xs `asTypeOf` (undefined :: HList '[a,b]) - ->>> let lr xs = asLen2 (applyAB (HMap HRead) xs) ->>> let ls xs = asLen2 (applyAB (HMap HShow) xs) ->>> let rl xs = applyAB (HMap HRead) (asLen2 xs) ->>> let sl xs = applyAB (HMap HShow) (asLen2 xs) - - ->>> :t lr -lr - :: (Read y, Read y1) => - HList ((':) * String ((':) * String ('[] *))) - -> HList ((':) * y ((':) * y1 ('[] *))) - ->>> :t rl -rl - :: (Read y, Read y1) => - HList ((':) * String ((':) * String ('[] *))) - -> HList ((':) * y ((':) * y1 ('[] *))) - - ->>> :t ls -ls - :: (Show y, Show y1) => - HList ((':) * y ((':) * y1 ('[] *))) - -> HList ((':) * String ((':) * String ('[] *))) - ->>> :t sl -sl - :: (Show y, Show y1) => - HList ((':) * y ((':) * y1 ('[] *))) - -> HList ((':) * String ((':) * String ('[] *))) - --} - -hMap f xs = applyAB (HMap f) xs - -newtype HMap f = HMap f - -instance (HMapCxt f as bs as' bs') => ApplyAB (HMap f) as bs where - applyAB (HMap f) = hMapAux f - -type HMapCxt f as bs as' bs' = (HMapAux f as' bs', as ~ HList as', bs ~ HList bs', - SameLength as' bs') - - --- | Ensure two lists have the same length. We do case analysis on the --- first one (hence the type must be known to the type checker). --- In contrast, the second list may be a type variable. -class SameLength' (es1 :: [k]) (es2 :: [m]) -instance (es2 ~ '[]) => SameLength' '[] es2 -instance (SameLength' xs ys, es2 ~ (y ': ys)) => SameLength' (x ': xs) es2 - -{- | symmetrical version of 'SameLength''. Written as a class instead of - - > type SameLength a b = (SameLength' a b, SameLength' b a) - -since ghc expands type synonyms, but not classes (and it seems to have the same -result) - --} -class (SameLength' x y, SameLength' y x) => - SameLength (x :: [k]) (y :: [m]) -instance (SameLength' x y, SameLength' y x) => SameLength x y - - - -class HMapAux f (l :: [*]) (r :: [*]) where - hMapAux :: SameLength l r => f -> HList l -> HList r - -instance HMapAux f '[] '[] where - hMapAux _ _ = HNil - -instance (ApplyAB f e e', HMapAux f l l', SameLength l l') - => HMapAux f (e ': l) (e' ': l') where - hMapAux f (HCons x l) = applyAB f x `HCons` hMapAux f l - - - - --- -------------------------------------------------------------------------- - --- **** alternative implementation --- $note currently broken - -newtype MapCar f = MapCar f - --- | Same as 'hMap' only a different implementation. -hMapMapCar :: (HFoldr (MapCar f) (HList '[]) l l') => - f -> HList l -> l' -hMapMapCar f = hFoldr (MapCar f) HNil - -instance ApplyAB f e e' => ApplyAB (MapCar f) (e,HList l) (HList (e' ': l)) where - applyAB (MapCar f) (e,l) = HCons (applyAB f e) l - - --- -------------------------------------------------------------------------- - --- *** @appEndo . mconcat . map Endo@ -{- | - ->>> let xs = length .*. (+1) .*. (*2) .*. HNil ->>> hComposeList xs "abc" -8 - - --} -hComposeList - :: (HFoldr Comp (a -> a) l (t -> a)) => HList l -> t -> a -hComposeList fs v0 = let r = hFoldr (undefined :: Comp) (\x -> x `asTypeOf` r) fs v0 in r - - --- -------------------------------------------------------------------------- - --- *** sequence -{- | - A heterogeneous version of - - > sequenceA :: (Applicative m) => [m a] -> m [a] - - Only now we operate on heterogeneous lists, where different elements - may have different types 'a'. - In the argument list of monadic values (m a_i), - although a_i may differ, the monad 'm' must be the same for all - elements. That's why we needed "Data.HList.TypeCastGeneric2" (currently (~)). - The typechecker will complain - if we attempt to use hSequence on a HList of monadic values with different - monads. - - The 'hSequence' problem was posed by Matthias Fischmann - in his message on the Haskell-Cafe list on Oct 8, 2006 - - - - - -} - -class (Applicative m, SameLength a b) => HSequence m a b | a -> b, m b -> a where - hSequence :: HList a -> m (HList b) -{- ^ - -[@Maybe@] - ->>> hSequence $ Just (1 :: Integer) `HCons` (Just 'c') `HCons` HNil -Just H[1, 'c'] - ->>> hSequence $ return 1 `HCons` Just 'c' `HCons` HNil -Just H[1, 'c'] - - -[@List@] - ->>> hSequence $ [1] `HCons` ['c'] `HCons` HNil -[H[1, 'c']] - - --} - -instance Applicative m => HSequence m '[] '[] where - hSequence _ = pure HNil - -instance (m1 ~ m, Applicative m, HSequence m as bs) => - HSequence m (m1 a ': as) (a ': bs) where - hSequence (HCons a b) = liftA2 HCons a (hSequence b) - --- data ConsM = ConsM --- consM = LiftA2 FHCons -newtype LiftA2 f = LiftA2 f - -instance (ApplyAB f (x,y) z, mz ~ m z, mxy ~ (m x, m y), Applicative m) => ApplyAB (LiftA2 f) mxy mz where - applyAB (LiftA2 f) xy = liftA2 (curry (applyAB f)) `uncurry` xy - -{- -instance (m1 ~ m, Applicative m) => ApplyAB ConsM (m a, m1 (HList l)) (m (HList (a ': l))) where -{- - type ApplyB ConsM (m a, m1 (HList l)) = Just (m (HList (a ': l))) - type ApplyA ConsM (m (HList (a ': l))) = Just (m a, m (HList l)) - -} - applyAB _ (me,ml) = liftA2 HCons me ml - -} - - --- **** alternative implementation - --- | 'hSequence2' is not recommended over 'hSequence' since it possibly doesn't --- allow inferring argument types from the result types. Otherwise this version --- should do exactly the same thing. --- --- The DataKinds version needs a little help to find the type of the --- return HNil, unlike the original version, which worked just fine as --- --- > hSequence l = hFoldr ConsM (return HNil) l - - -{- -hSequence2 :: HSequence2 l f a => HList l -> f a -hSequence2 l = - let rHNil = pure HNil `asTypeOf` (liftA undefined x) - x = hFoldr ConsM rHNil l - in x - - --- | abbreviation for the constraint on 'hSequence2' -type HSequence2 l f a = (Applicative f, HFoldr ConsM (f (HList ('[]))) l (f a)) --} - - --- -------------------------------------------------------------------------- - - --- -------------------------------------------------------------------------- --- ** producing homogenous lists - --- *** map (no sequencing) --- $mapOut This one we implement via hFoldr - -newtype Mapcar f = Mapcar f - -instance (l ~ [e'], ApplyAB f e e', el ~ (e,l)) => ApplyAB (Mapcar f) el l where - applyAB (Mapcar f) (e, l) = applyAB f e : l - --- A synonym for the complex constraint -type HMapOut f l e = (HFoldr (Mapcar f) [e] l [e]) - -hMapOut :: forall f e l. HMapOut f l e => f -> HList l -> [e] -hMapOut f l = hFoldr (Mapcar f) ([] :: [e]) l - - --- -------------------------------------------------------------------------- --- *** mapM - --- | --- --- > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b] --- --- Likewise for mapM_. --- --- See 'hSequence' if the result list should also be heterogenous. - -hMapM :: (Monad m, HMapOut f l (m e)) => f -> HList l -> [m e] -hMapM f = hMapOut f - --- | GHC doesn't like its own type. --- hMapM_ :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m () --- Without explicit type signature, it's Ok. Sigh. --- Anyway, Hugs does insist on a better type. So we restrict as follows: --- -hMapM_ :: (Monad m, HMapOut f l (m ())) => f -> HList l -> m () -hMapM_ f = sequence_ . disambiguate . hMapM f - where - disambiguate :: [q ()] -> [q ()] - disambiguate = id - - - - - --- -------------------------------------------------------------------------- --- * Type-level equality for lists ('HEq') - -instance HEq '[] '[] True -instance HEq '[] (e ': l) False -instance HEq (e ': l) '[] False -instance (HEq e1 e2 b1, HEq l1 l2 b2, br ~ HAnd b1 b2) - => HEq (e1 ': l1) (e2 ': l2) br - --- -------------------------------------------------------------------------- --- * Ensure a list to contain HNats only --- | We do so constructively, converting the HList whose elements --- are Proxy HNat to [HNat]. The latter kind is unpopulated and --- is present only at the type level. - -type family HNats (l :: [*]) :: [HNat] -type instance HNats '[] = '[] -type instance HNats (Proxy n ': l) = n ': HNats l - -hNats :: HList l -> Proxy (HNats l) -hNats = undefined - - --- -------------------------------------------------------------------------- --- * Membership tests - --- | Check to see if an HList contains an element with a given type --- This is a type-level only test - -class HMember (e1 :: k) (l :: [k]) (b :: Bool) | e1 l -> b -instance HMember e1 '[] False -instance (HEq e1 e b, HMember' b e1 l br) => HMember e1 (e ': l) br -class HMember' (b0 :: Bool) (e1 :: k) (l :: [k]) (b :: Bool) | b0 e1 l -> b -instance HMember' True e1 l True -instance (HMember e1 l br) => HMember' False e1 l br - --- The following is a similar type-only membership test --- It uses the user-supplied curried type equality predicate pred -type family HMemberP pred e1 (l :: [*]) :: Bool -type instance HMemberP pred e1 '[] = False ---type instance HMemberP pred e1 (e ': l) = HMemberP' pred e1 l (ApplyR pred (e1,e)) - -type family HMemberP' pred e1 (l :: [*]) pb :: Bool -type instance HMemberP' pred e1 l (Proxy True) = True -type instance HMemberP' pred e1 l (Proxy False) = HMemberP pred e1 l - - -hMember :: HMember e l b => Proxy e -> Proxy l -> Proxy b -hMember = undefined - --- ** Another type-level membership test --- --- | Check to see if an element e occurs in a list l --- If not, return 'Nothing --- If the element does occur, return 'Just l1 --- where l1 is a type-level list without e -class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r -instance HMemberM e1 '[] 'Nothing -instance (HEq e1 e b, HMemberM1 b e1 (e ': l) res) - => HMemberM e1 (e ': l) res - -class HMemberM1 (b::Bool) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r -instance HMemberM1 True e1 (e ': l) ('Just l) -instance (HMemberM e1 l r, HMemberM2 r e1 (e ': l) res) - => HMemberM1 False e1 (e ': l) res - -class HMemberM2 (b::Maybe [k]) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r -instance HMemberM2 Nothing e1 l Nothing -instance HMemberM2 (Just l1) e1 (e ': l) (Just (e ': l1)) - --- -------------------------------------------------------------------------- - --- * Staged equality for lists --- $note removed. use Typeable instead - -{- -instance HStagedEq (HList '[]) (HList '[]) - where - hStagedEq _ _ = True - -instance HStagedEq (HList '[]) (HList (e ': l)) - where - hStagedEq _ _ = False - -instance HStagedEq (HList (e ': l)) (HList '[]) - where - hStagedEq _ _ = False - -instance ( HEq e e' b - , HStagedEq (HList l) (HList l') - , HStagedEq' b e e' - ) - => HStagedEq (HList (e ': l)) (HList (e' ': l')) - where - hStagedEq (HCons e l) (HCons e' l') = (hStagedEq' b e e') && b' - where - b = proxy :: Proxy b - b' = hStagedEq l l' - -class HStagedEq' (b :: Bool) e e' - where - hStagedEq' :: Proxy b -> e -> e' -> Bool - -instance HStagedEq' False e e' - where - hStagedEq' _ _ _ = False - -instance Eq e => HStagedEq' True e e - where - hStagedEq' _ = (==) --} - -{- - - - --- * Static set property based on HEq -class HSet l -instance HSet HNil -instance (HMember e l HFalse, HSet l) => HSet (HCons e l) --} - --- * Find an element in a set based on HEq --- | It is a pure type-level operation -class HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n - -instance (HEq e1 e2 b, HFind' b e1 l n) => HFind e1 (e2 ': l) n - -class HFind' (b::Bool) (e :: k) (l::[k]) (n::HNat) | b e l -> n -instance HFind' True e l HZero -instance HFind e l n => HFind' False e l (HSucc n) - - - --- ** Membership test based on type equality - --- | could be an associated type if HEq had one -class HTMember e (l :: [*]) (b :: Bool) | e l -> b -instance HTMember e '[] False -instance (HEq e e' b, HTMember e l b', HOr b b' ~ b'') - => HTMember e (e' ': l) b'' - -hTMember :: HTMember e l b => e -> HList l -> Proxy b -hTMember _ _ = Proxy - - --- * Intersection based on HTMember - -class HTIntersect l1 l2 l3 | l1 l2 -> l3 - where - -- | Like 'Data.List.intersect' - hTIntersect :: HList l1 -> HList l2 -> HList l3 - -instance HTIntersect '[] l '[] - where - hTIntersect _ _ = HNil - -instance ( HTMember h l1 b - , HTIntersectBool b h t l1 l2 - ) - => HTIntersect (h ': t) l1 l2 - where - hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1 - where - b = hTMember h l1 - -class HTIntersectBool (b :: Bool) h t l1 l2 | b h t l1 -> l2 - where - hTIntersectBool :: Proxy b -> h -> HList t -> HList l1 -> HList l2 - -instance HTIntersect t l1 l2 - => HTIntersectBool True h t l1 (h ': l2) - where - hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1) - -instance HTIntersect t l1 l2 - => HTIntersectBool False h t l1 l2 - where - hTIntersectBool _ _ t l1 = hTIntersect t l1 - - --- * Turn a heterogeneous list into a homogeneous one - --- | Same as @hMapOut Id@ -class HList2List l e - where - hList2List :: HList l -> [e] - -instance HList2List '[] e - where - hList2List HNil = [] - -instance HList2List l e - => HList2List (e ': l) e - where - hList2List (HCons e l) = e:hList2List l - - - - --- -------------------------------------------------------------------------- --- * With 'HMaybe' - --- ** Turn list in a list of justs --- | the same as @map Just@ --- --- >>> toHJust (2 .*. 'a' .*. HNil) --- H[HJust 2, HJust 'a'] --- --- >>> toHJust2 (2 .*. 'a' .*. HNil) --- H[HJust 2, HJust 'a'] - -class ToHJust l l' | l -> l', l' -> l - where - toHJust :: HList l -> HList l' - -instance ToHJust '[] '[] - where - toHJust HNil = HNil - -instance ToHJust l l' => ToHJust (e ': l) (HJust e ': l') - where - toHJust (HCons e l) = HCons (HJust e) (toHJust l) - --- | alternative implementation. The Apply instance is in "Data.HList.FakePrelude". --- A longer type could be inferred. --- toHJust2 :: (HMap' (HJust ()) a b) => HList a -> HList b -toHJust2 xs = hMap (HJust ()) xs - --- -------------------------------------------------------------------------- --- ** Extract justs from list of maybes --- --- >>> let xs = 2 .*. 'a' .*. HNil --- >>> fromHJust (toHJust xs) == xs --- True - -class FromHJust l - where - type FromHJustR l :: [*] - fromHJust :: HList l -> HList (FromHJustR l) - -instance FromHJust '[] - where - type FromHJustR '[] = '[] - fromHJust HNil = HNil - -instance FromHJust l => FromHJust (HNothing ': l) - where - type FromHJustR (HNothing ': l) = FromHJustR l - fromHJust (HCons _ l) = fromHJust l - -instance FromHJust l => FromHJust (HJust e ': l) - where - type FromHJustR (HJust e ': l) = e ': FromHJustR l - fromHJust (HCons (HJust e) l) = HCons e (fromHJust l) - --- *** alternative implementation - --- | A longer type could be inferred. --- fromHJust2 :: (HMap' HFromJust a b) => HList a -> HList b -fromHJust2 xs = hMap HFromJust xs - -data HFromJust = HFromJust -instance (hJustA ~ HJust a) => ApplyAB HFromJust hJustA a where - applyAB _ (HJust a) = a - - --- -------------------------------------------------------------------------- --- * Annotated lists - -data HAddTag t = HAddTag t -data HRmTag = HRmTag - --- hAddTag :: HMap' (HAddTag t) l r => t -> HList l -> HList r -hAddTag t l = hMap (HAddTag t) l - --- hRmTag :: HMap HRmTag l => HList l -> HList (HMapR HRmTag l) -hRmTag l = hMap HRmTag l - -instance (et ~ (e,t)) => ApplyAB (HAddTag t) e et - where - applyAB (HAddTag t) e = (e,t) - - -instance (e' ~ e) => ApplyAB HRmTag (e,t) e' - where - applyAB _ (e,_) = e - - --- | Annotate list with a type-level Boolean --- hFlag :: HMap' (HAddTag (Proxy True)) l r => HList l -> HList r -hFlag l = hAddTag hTrue l - - --- -------------------------------------------------------------------------- --- * Splitting by HTrue and HFalse - --- | Analogus to Data.List.'Data.List.partition' 'snd' --- --- >>> hSplit $ (2,hTrue) .*. (3,hTrue) .*. (1,hFalse) .*. HNil --- (H[2, 3],H[1]) --- --- it might make more sense to instead have @LVPair Bool e@ --- instead of @(e, Proxy Bool)@ since the former has the same --- runtime representation as @e@ - -class HSplit l - where - type HSplitT l :: [*] - type HSplitF l :: [*] - hSplit :: HList l -> (HList (HSplitT l), HList (HSplitF l)) - -instance HSplit '[] - where - type HSplitT '[] = '[] - type HSplitF '[] = '[] - hSplit HNil = (HNil,HNil) - -instance HSplit l => HSplit ((e, Proxy True) ': l) - where - - type HSplitT ((e,Proxy True) ': l) = e ': HSplitT l - type HSplitF ((e,Proxy True) ': l) = HSplitF l - - hSplit (HCons (e,_) l) = (HCons e l',l'') - where - (l',l'') = hSplit l - -instance HSplit l => HSplit ((e,Proxy False) ': l) - where - type HSplitT ((e,Proxy False) ': l) = HSplitT l - type HSplitF ((e,Proxy False) ': l) = e ': HSplitF l - - hSplit (HCons (e,_) l) = (l',HCons e l'') - where - (l',l'') = hSplit l - -{- - -Let expansion makes a difference to Hugs: - -HListPrelude> let x = (hFlag (HCons "1" HNil)) in hSplit x -(HCons "1" HNil,HNil) -HListPrelude> hSplit (hFlag (HCons "1" HNil)) -ERROR - Unresolved overloading -*** Type : HSplit (HCons ([Char],HTrue) HNil) a b => (a,b) -*** Expression : hSplit (hFlag (HCons "1" HNil)) - - --} +{-# LANGUAGE CPP #-} +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Basic declarations for typeful heterogeneous lists. + + -} + +module Data.HList.HList where + +import Data.HList.FakePrelude +import Data.HList.HListPrelude + +import Text.ParserCombinators.ReadP +import Data.List + +import LensDefs + +import Data.Array (Ix) + +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup +#endif + +-- -------------------------------------------------------------------------- +-- * Heterogeneous type sequences +{- $note + +There are three sensible ways to define HLists: + +@ +data HList (l::[*]) where + HNil :: HList '[] + HCons :: e -> HList l -> HList (e ': l) +@ + +This ensures that sequences can only be formed with Nil +and Cons. The argument to HList is a promoted lists (kind @[*]@), +which has a more attractive syntax. + + +Earlier versions of HList used an algebraic data type: + +@ +data HCons a b = HCons a b +data HNil = HNil +@ + +Disadvantages: + +* values with types like @HCons Int Double@ to be created, + which are nonsense to the functions in HList + +* some recursive functions do not need a class with the GADT. For example: + + @ + hInit :: HListGADT (x ': xs) -> HListGADT (HInit (x ': xs)) + hInit (HCons x xs@(HCons _ _)) = HCons x (hInit xs) + hInit (HCons _ HNil) = HNil + + type family HInit (xs :: [k]) :: [k] + @ + + but without the GADT, 'hInit' is written as in a class, + which complicates inferred types + + +Advantages + +* lazy pattern matches are allowed, so lazy pattern matching + on a value @undefined :: HList [a,b,c]@ can create the + spine of the list. 'hProxies' avoids the use of 'undefined', + but a slightly more complicated class context has to be written + or inferred. + +* type inference is better if you want to directly pattern match + + +* 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: + + + + +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 + + + + + -} + +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 (<>) diff --git a/Data/HList/HListPrelude.hs b/Data/HList/HListPrelude.hs --- a/Data/HList/HListPrelude.hs +++ b/Data/HList/HListPrelude.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- | The HList library @@ -13,11 +14,30 @@ import Data.HList.FakePrelude + class HExtend e l where type HExtendR e l (.*.) :: e -> l -> HExtendR e l + infixr 2 .*. + +-- | to keep types shorter, '.*.' used with Proxy avoids +-- producing a @Proxy :: Proxy '[Label x,Label y,Label z]@ +-- if @Proxy :: Proxy '[x,y,z]@ is not a kind error (as it +-- is when mixing Label6 and Label3 labels). +-- +-- ghc-7.6 does not accept @Proxy ('[] :: [k])@ so for now +-- require @k ~ *@ +instance HExtend (Label x) (Proxy ('[] :: [*])) where + type HExtendR (Label x) (Proxy ('[] :: [*])) = Proxy '[x] + (.*.) _ _ = Proxy + + +-- | similar to 'emptyRecord', 'emptyTIP', emptyHList (actually called 'HNil'), +-- except emptyProxy is the rightmost argument to '.*.' +emptyProxy = Proxy :: Proxy ('[] :: [*]) + -- Poly-kinded class SubType l l' @@ -38,14 +58,14 @@ -- Class to test that a type is "free" in a type sequence -- polykinded -class HOccursNot e l +class HOccursNot (e :: k) (l :: [k]) class HProject l l' where hProject :: l -> l' -- | Map a type (key) to a natural (index) within the collection -- This is a purely type-level computation -class HType2HNat e l (n :: HNat) | e l -> n +class HType2HNat (e :: k) (l :: [k]) (n :: HNat) | e l -> n -- | and lift to the list of types class HTypes2HNats es l (ns :: [HNat]) | es l -> ns @@ -57,4 +77,61 @@ class HDeleteMany e l l' | e l -> l' where hDeleteMany :: Proxy e -> l -> l' + + +class HDeleteAtLabel (r :: [*] -> *) (l :: k) v v' | l v -> v' where + hDeleteAtLabel :: Label l -> r v -> r v' + + + + +-- | 'unzip' +class SameLengths [x,y,xy] => HUnzip (r :: [*] -> *) x y xy + | x y -> xy, xy -> x y where + hUnzip :: r xy -> (r x, r y) + +-- | 'zip'. Variant supports hUnzip, but not hZip ('hZipVariant' returns a Maybe) +class HUnzip r x y xy => HZip (r :: [*] -> *) x y xy where + hZip :: r x -> r y -> r xy + +#if __GLASGOW_HASKELL__ != 706 +instance (lv ~ Tagged l v, HUnzip Proxy ls vs lvs) + => HUnzip Proxy (Label l ': ls) (v ': vs) (lv ': lvs) where + hUnzip _ = (Proxy, Proxy) + +instance HUnzip Proxy '[] '[] '[] where hUnzip _ = (Proxy, Proxy) + + +{- | Missing from GHC-7.6.3 due to a bug: + +> let r = hEnd $ hBuild 1 2 3 +> *Data.HList> hZipList r r +> H[(1,1),(2,2),(3,3)] +> *Data.HList> hZip r r +> +> :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 :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 + diff --git a/Data/HList/HOccurs.hs b/Data/HList/HOccurs.hs --- a/Data/HList/HOccurs.hs +++ b/Data/HList/HOccurs.hs @@ -20,18 +20,18 @@ -- whose head has the type e. Return HNil if l does not have -- an element of type e. -class HOccurrence e1 (l :: [*]) (l' :: [*]) | e1 l -> l' where - hOccurrence :: e1 -> HList l -> HList l' +class HOccurrence (e1 :: *) (l :: [*]) (l' :: [*]) | e1 l -> l' where + hOccurrence :: Proxy e1 -> HList l -> HList l' instance HOccurrence e1 '[] '[] where hOccurrence _ = id instance (HEq e1 e b, HOccurrence' b e1 (e ': l) l') => HOccurrence e1 (e ': l) l' where - hOccurrence = hOccurrence' (undefined::Proxy b) + hOccurrence = hOccurrence' (Proxy::Proxy b) -class HOccurrence' (b :: Bool) e1 (l :: [*]) (l' :: [*]) | b e1 l -> l' where - hOccurrence' :: Proxy b -> e1 -> HList l -> HList l' +class HOccurrence' (b :: Bool) (e1 :: *) (l :: [*]) (l' :: [*]) | b e1 l -> l' where + hOccurrence' :: Proxy b -> Proxy e1 -> HList l -> HList l' instance HOccurrence' True e1 (e ': l) (e ': l) where hOccurrence' _ _ = id @@ -46,10 +46,10 @@ class HOccursMany e (l :: [*]) where hOccursMany :: HList l -> [e] -instance (HOccurrence e l l', HOccursMany' e l') +instance (HOccurrence e l l', HOccursMany' e l') => HOccursMany e l where - hOccursMany l = hOccursMany' (hOccurrence (undefined::e) l) + hOccursMany l = hOccursMany' (hOccurrence (Proxy::Proxy e) l) class HOccursMany' e l where hOccursMany' :: HList l -> [e] @@ -65,16 +65,16 @@ -- One or more occurrences hOccursMany1 :: forall e l l'. - (HOccurrence e l (e ': l'), HOccursMany e l') => - HList l -> (e,[e]) -hOccursMany1 l = case hOccurrence (undefined::e) l of - (HCons e l') -> (e,hOccursMany (l'::HList l')) + (HOccurrence e l (e ': l'), HOccursMany e l') => + HList l -> (e,[e]) +hOccursMany1 l = case hOccurrence (Proxy :: Proxy e) l of + (HCons e l') -> (e,hOccursMany (l'::HList l')) -- -------------------------------------------------------------------------- -- The first occurrence hOccursFst :: forall e l l'. HOccurrence e l (e ': l') => HList l -> e -hOccursFst l = case hOccurrence (undefined::e) l of HCons e _ -> e +hOccursFst l = case hOccurrence (Proxy::Proxy e) l of HCons e _ -> e -- -------------------------------------------------------------------------- -- One occurrence and nothing is left @@ -82,26 +82,36 @@ data TypeNotFound e -instance (HOccurrence e (x ': y) l', HOccurs' e l') +instance (HOccurrence e (x ': y) l', HOccurs' e l' (x ': y)) => HOccurs e (HList (x ': y)) where - hOccurs = hOccurs' . hOccurrence (undefined::e) + hOccurs = hOccurs' (Proxy :: Proxy (x ': y)) . hOccurrence (Proxy ::Proxy e) -class HOccurs' e l where - hOccurs' :: HList l -> e +-- | l0 is the original list so that when we reach the end of l +-- without finding an e, we can report an error that gives an +-- idea about what the original list was. +class HOccurs' e l (l0 :: [*]) where + hOccurs' :: Proxy l0 -> HList l -> e -instance Fail (TypeNotFound e) => HOccurs' e '[] where - hOccurs' = undefined +instance Fail (FieldNotFound e (HList l0)) => HOccurs' e '[] l0 where + hOccurs' = error "HOccurs'' Fail failed" -instance (e ~ e1, HOccursNot e l) => HOccurs' e (e ': l) where - hOccurs' (HCons e _) = e +instance HOccursNot e l => HOccurs' e (e ': l) l0 where + hOccurs' _ (HCons e _) = e +-- | lookup a value in the collection (TIP usually) and return the TIP with that +-- element deleted. Used to implement 'tipyTuple'. +hOccursRest tip = case hOccurs tip of + x -> (x, hDeleteAtLabel (asLabel x) tip) + where asLabel :: x -> Label x + asLabel _ = Label + -- -------------------------------------------------------------------------- -- Zero or at least one occurrence -hOccursOpt :: forall e l l'. - (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e -hOccursOpt = hOccursOpt' . hOccurrence (undefined::e) +hOccursOpt :: forall e l l'. + (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e +hOccursOpt = hOccursOpt' . hOccurrence (Proxy :: Proxy e) class HOccursOpt' e l where hOccursOpt' :: HList l -> Maybe e @@ -115,12 +125,15 @@ -- -------------------------------------------------------------------------- -- Class to test that a type is "free" in a type sequence -data TypeFound e -instance HOccursNot e ('[]::[*]) -instance (HEq e e1 b, HOccursNot' b e l) => HOccursNot e (e1 ': l) -class HOccursNot' (b :: Bool) e (l :: [*]) -instance Fail (TypeFound e) => HOccursNot' True e l -instance HOccursNot e l => HOccursNot' False e l +instance HOccursNot1 e xs xs => HOccursNot e xs + +class HOccursNot1 (e :: k) (xs :: [k]) (xs0 :: [k]) + +instance HOccursNot1 (e :: k) ('[]::[k]) l0 +instance (HEq e e1 b, HOccursNot2 b e l l0) => HOccursNot1 e (e1 ': l) l0 +class HOccursNot2 (b :: Bool) e (l :: [k]) (l0 :: [k]) +instance Fail (ExcessFieldFound e l0) => HOccursNot2 True e l l0 +instance HOccursNot1 e l l0 => HOccursNot2 False e l l0 -- -------------------------------------------------------------------------- diff --git a/Data/HList/HSort.hs b/Data/HList/HSort.hs new file mode 100644 --- /dev/null +++ b/Data/HList/HSort.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE CPP #-} +{- | Description: sorting + +Benchmarks for these functions can be found at +. + +See +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 + +-} diff --git a/Data/HList/HTypeIndexed.hs b/Data/HList/HTypeIndexed.hs --- a/Data/HList/HTypeIndexed.hs +++ b/Data/HList/HTypeIndexed.hs @@ -26,8 +26,8 @@ instance HOccursNot e l => HType2HNatCase True e l HZero instance HType2HNat e l n => HType2HNatCase False e l (HSucc n) -hType2HNat :: HType2HNat e l n => Proxy e -> l -> Proxy n -hType2HNat _ _ = undefined +hType2HNat :: HType2HNat e l n => proxy1 e -> proxy l -> Proxy n +hType2HNat _ _ = Proxy -- | And lift to the list of types @@ -36,9 +36,9 @@ instance (HType2HNat e l n, HTypes2HNats es l ns) => HTypes2HNats (e ': es) (l :: [*]) (n ': ns) -hTypes2HNats :: HTypes2HNats es l ns => - Proxy (es :: [*]) -> HList l -> Proxy (ns :: [HNat]) -hTypes2HNats = undefined +hTypes2HNats :: HTypes2HNats es l ns => + Proxy (es :: [*]) -> hlist l -> Proxy (ns :: [HNat]) +hTypes2HNats _ _ = Proxy -- -------------------------------------------------------------------------- -- Implementing the generic interfaces @@ -48,8 +48,8 @@ instance (HEq e1 e b, HDeleteManyCase b e1 e l l1) => HDeleteMany e1 (HList (e ': l)) (HList l1) where - hDeleteMany p (HCons e l) = - hDeleteManyCase (undefined:: Proxy b) p e l + hDeleteMany p (HCons e l) = + hDeleteManyCase (Proxy :: Proxy b) p e l class HDeleteManyCase (b :: Bool) e1 e l l1 | b e1 e l -> l1 where hDeleteManyCase :: Proxy b -> Proxy e1 -> e -> HList l -> HList l1 @@ -66,24 +66,16 @@ -- -------------------------------------------------------------------------- -- Type-indexed operations in terms of the natural-based primitives -hDeleteAt :: forall e l n. (HDeleteAtHNat n l, HType2HNat e l n) => - Proxy e -> HList l -> HList (HDeleteAtHNatR n l) -hDeleteAt _p l = hDeleteAtHNat (undefined :: Proxy n) l +hDeleteAt p l = hDeleteAtHNat (hType2HNat p l) l -hUpdateAt :: forall n e l. - (HUpdateAtHNat n e l, HType2HNat e l n) => - e -> HList l -> (HList (HUpdateAtHNatR n e l)) -hUpdateAt e l = hUpdateAtHNat (undefined:: Proxy n) e l +hUpdateAt e l = hUpdateAtHNat (hType2HNat (Just e) l) e l -hProjectBy :: forall (ns :: [HNat]) (ps :: [*]) (l :: [*]). - (HProjectByHNatsCtx ns l, HTypes2HNats ps l ns, - ps ~ (HProjectByHNatsR ns l)) => - Proxy ps -> HList l -> HList ps -hProjectBy _ps l = hProjectByHNats (undefined::Proxy ns) l +hProjectBy ps l = hProjectByHNats (hTypes2HNats ps l) l -hSplitBy :: forall (ps :: [*]) l ns. - (HProjectByHNatsCtx ns l, HProjectAwayByHNatsCtx ns l, - HTypes2HNats ps l ns) => - Proxy ps -> HList l -> (HList (HProjectByHNatsR ns l), - HList (HProjectAwayByHNatsR ns l)) -hSplitBy _ps l = hSplitByHNats (undefined::Proxy ns) l +hSplitBy ps l = hSplitByHNats (hTypes2HNats ps l) l + + +-- | should this instead delete the first element of that type? +instance (HDeleteAtHNat n l, HType2HNat e l n, l' ~ HDeleteAtHNatR n l) + => HDeleteAtLabel HList e l l' where + hDeleteAtLabel _ = hDeleteAtHNat (Proxy :: Proxy n) diff --git a/Data/HList/HZip.hs b/Data/HList/HZip.hs --- a/Data/HList/HZip.hs +++ b/Data/HList/HZip.hs @@ -17,17 +17,7 @@ -- * zip -- ** functional dependency -class HZip x y l | x y -> l, l -> x y where - hZip :: HList x -> HList y -> HList l - hUnzip :: HList l -> (HList x, HList y) - -instance HZip '[] '[] '[] where - hZip _ _ = HNil - hUnzip _ = (HNil, HNil) - -instance ((x,y)~z, HZip xs ys zs) => HZip (x ': xs) (y ': ys) (z ': zs) where - hZip (HCons x xs) (HCons y ys) = (x,y) `HCons` hZip xs ys - hUnzip (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip zs in (x `HCons` xs, y `HCons` ys) +-- $note1 moved to "Data.HList.HList" to avoid an orphan instance -- ** type family -- $note 'hZip2' can be written as a standalone function, with an appropriate @@ -53,7 +43,6 @@ type MapFst (z ': zs) = ( Fst z ': MapFst zs ) type MapSnd (z ': zs) = ( Snd z ': MapSnd zs ) hZip2 (HCons x xs) (HCons y ys) = HCons (x,y) (hZip2 xs ys) - hZip2 _ _ = error "Data.HList.HZip.hZip2: impossible case" hUnzip2 (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip2 zs in (x `HCons` xs, y `HCons` ys) @@ -87,12 +76,12 @@ The original list: >>> ex -H[H[1, 2], H['a', 'b'], H[3, 5]] +H[H[1,2],H['a','b'],H[3,5]] And transposed: >>> hTranspose ex -H[H[1, 'a', 3], H[2, 'b', 5]] +H[H[1,'a',3],H[2,'b',5]] -} hTranspose x = hFoldr HZipF (hReplicate (hLength (hHead x)) HNil) x @@ -109,7 +98,7 @@ instance HZip3 '[] '[] '[] where hZip3 _ _ = HNil -instance (HList (x ': y) ~z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where +instance (HList (x ': y) ~ z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where hZip3 (HCons x xs) (HCons y ys) = HCons x y `HCons` hZip3 xs ys data HZipF = HZipF diff --git a/Data/HList/Keyword.hs b/Data/HList/Keyword.hs --- a/Data/HList/Keyword.hs +++ b/Data/HList/Keyword.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE OverlappingInstances, StandaloneDeriving #-} -{- | keyword functions +{- | Description: keyword arguments +The public interface is exposed in + -} module Data.HList.Keyword ( @@ -58,11 +59,13 @@ -- * todo -- $todo + -- * internal for type signature prettiness + TaggedToKW, ) where import GHC.TypeLits import Data.HList.FakePrelude -import Data.HList.TypeEqO () +import Data.HList.TypeEqO import Data.HList.HListPrelude import Data.HList.HList import Data.HList.Record @@ -71,6 +74,7 @@ >>> :set -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses >>> :set -XScopedTypeVariables -XOverlappingInstances -XTypeFamilies + >>> :set -fcontext-stack=100 We will be using an example inspired by a graphics toolkit -- the area which really benefits from keyword arguments. We first define our @@ -201,7 +205,7 @@ If we omit a required argument, we get a type error: > ] testse1 = let f x = kw make_square HNil Color Red x -> ] in "here: " ++ f Origin (0,10) +> ] in "here: " ++ f Origin (0,10) > > Couldn't match `ErrReqdArgNotFound Size' against `[Char]' > Expected type: ErrReqdArgNotFound Size @@ -211,11 +215,11 @@ message if we pass to a keyword function an argument it does not expect: > ] testse2 = let f x = kw make_square HNil Color Red x -> ] in "here: " ++ f Origin (0,10) Size (1::Int) -> ] RaisedBorder False +> ] in "here: " ++ f Origin (0,10) Size (1::Int) +> ] RaisedBorder False > > No instances for (Fail (ErrUnexpectedKW RaisedBorder), -> KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char]) +> KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char]) > arising from use of `f' at ... > In the second argument of `(++)', namely > `f Origin (0,10) Size (1 :: Int) RaisedBorder False' @@ -260,7 +264,7 @@ > katest21 = kwapply f2 (Color .*. Red .*. Size .*. (1::Int) .*. HNil) > > katest3 = kwapply f3 (Size .*. (1::Int) .*. Origin .*. (2.0::Float) .*. -> Color .*. Red .*. HNil) +> Color .*. Red .*. HNil) -} @@ -317,12 +321,7 @@ data ErrReqdArgNotFound x data ErrUnexpectedKW x --- | All our keywords must be registered - -class IsKeyFN t (flag :: Bool) | t-> flag --- | overlapping/fallback case -instance (False ~ flag) => IsKeyFN t flag instance IsKeyFN (Label (s :: Symbol) -> a -> b) True {- ^ labels that impose no restriction on the type of the (single) argument which follows @@ -365,7 +364,7 @@ kwapply f _ = f instance (HEq kw kw' flag, - KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r) + KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r) => KWApply (kw ->a->f') (kw' ': a' ': tail) r where kwapply = kwapply' (Proxy :: Proxy flag) @@ -376,15 +375,14 @@ => KWApply' True (kw->v->f') (kw ': v' ': tail) r where kwapply' _ f (HCons kw_ (HCons v' tl)) = kwapply (f kw_ v') tl - kwapply' _ _ _ = error "Data.HList.Keyword.kwapply': impossible 1" -- | Rotate the arg list ... -instance (HAppendList tail '[kw , v] ~ l', - KWApply f l' r) +instance (HAppendListR tail '[kw , v] ~ l', + HAppendList tail '[kw, v], + KWApply f l' r) => KWApply' False f (kw ': v ': tail) r where kwapply' _ f (HCons kw_ (HCons v tl)) = - kwapply f (hAppend tl (kw_ .*. v .*. HNil)) - kwapply' _ _ _ = error "Data.HList.Keyword.kwapply': impossible 2" + kwapply f (hAppend tl (kw_ .*. v .*. HNil)) {- | @@ -404,11 +402,10 @@ >>> :t reflect_fk (undefined::Size->Int->Color->CommonColor->String) reflect_fk (undefined::Size->Int->Color->CommonColor->String) - :: Arg [*] ((':) * Size ((':) * Color ('[] *))) ('[] *) + :: Arg '[Size, Color] '[] >>> :t reflect_fk (undefined::Size->Int->()->Int) -reflect_fk (undefined::Size->Int->()->Int) - :: Arg [*] ((':) * Size ('[] *)) ('[] *) +reflect_fk (undefined::Size->Int->()->Int) :: Arg '[Size] '[] -} @@ -426,7 +423,7 @@ kwdo :: f -> arg_desc -> HList arg_def -> r instance (IsKeyFN r rflag, - KW' rflag f arg_desc arg_def r) + KW' rflag f arg_desc arg_def r) => KW f arg_desc arg_def r where kwdo = kw' (Proxy ::Proxy rflag) @@ -465,8 +462,8 @@ instance KWMerge' kw arg_def atail arg_values arg_def f r => KWMerge (kw ': atail) arg_values arg_def f r where kwmerge (Arg arg_values) arg_def = - kwmerge' (undefined :: kw) arg_def - ((Arg arg_values)::Arg atail arg_values) arg_def + kwmerge' (undefined :: kw) arg_def + ((Arg arg_values)::Arg atail arg_values) arg_def class KWMerge' kw list atail arg_values arg_def f r where kwmerge':: kw -> HList list -> (Arg atail arg_values) -> HList arg_def -> f -> r @@ -476,7 +473,7 @@ nff where kwmerge' = undefined instance (HEq kw kw' flag, - KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r) + KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r) => KWMerge' kw (kw' ': etc) atail arg_values arg_def f r where kwmerge' = kwmerge'' (Proxy :: Proxy flag) @@ -484,19 +481,17 @@ where kwmerge'':: Proxy flag -> kw -> HList list -> Arg atail arg_values -> HList arg_def - -> f -> r + -> f -> r instance KWMerge atail (kw ': v ': arg_values) arg_def f r => KWMerge'' True kw (kw ': v ': tail) atail arg_values arg_def f r where kwmerge'' _ _ (HCons kw_ (HCons v _)) (Arg arg_values) = - kwmerge ((Arg (kw_ .*. v .*. arg_values)):: - (Arg atail (kw ': v ': arg_values))) - kwmerge'' _ _ _ _ = error "Data.HList.kwmerge'': impossible" + kwmerge ((Arg (kw_ .*. v .*. arg_values)):: + (Arg atail (kw ': v ': arg_values))) instance KWMerge' kw tail atail arg_values arg_def f r => KWMerge'' False kw (kw' ': v' ': tail) atail arg_values arg_def f r where kwmerge'' _ kw_ (HCons _ (HCons _ tl)) = kwmerge' kw_ tl - kwmerge'' _ _ _ = error "Data.HList.kwmerge'': impossible 2" -- | Add the real argument to the Arg structure, and continue @@ -505,11 +500,11 @@ instance (HDelete kw arg_types arg_types', - KW f (Arg arg_types' (kw ': a ': arg_values)) arg_def r) + KW f (Arg arg_types' (kw ': a ': arg_values)) arg_def r) => KWAcc (Arg arg_types arg_values) kw a f arg_def r where kwaccum (Arg arg_values) kw_ a f = - kwdo f (Arg (kw_ .*. a .*. arg_values):: - Arg arg_types' (kw ': a ': arg_values)) + kwdo f (Arg (kw_ .*. a .*. arg_values):: + Arg arg_types' (kw ': a ': arg_values)) -- | Delete e from l to yield l' The element e must occur in l @@ -581,8 +576,7 @@ -} -recToKW :: forall a b. (HMapAux TaggedToKW a b, SameLength a b, - SameLength b a, HConcat b) => +recToKW :: forall a b. (HMapCxt HList TaggedToKW a b, HConcat b) => Record a -> HList (HConcatR b) recToKW (Record r) = hConcat (hMap TaggedToKW r :: HList b) @@ -635,7 +629,7 @@ Our implementation is a trivial extension of the strongly-typed polymorphic open records described in - + In fact, the implementation relies on the HList library. To run the code (which this message is), one needs to download the HList library diff --git a/Data/HList/Label3.hs b/Data/HList/Label3.hs --- a/Data/HList/Label3.hs +++ b/Data/HList/Label3.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- | @@ -35,21 +36,41 @@ module Data.HList.Label3 where import Data.HList.FakePrelude +import Data.HList.HListPrelude +import GHC.TypeLits +import Data.Typeable +{- $setup -data Lbl (x :: HNat) ns desc -- labels are exclusively type-level entities +>>> let label3 = Label :: Label (Lbl HZero () ()) +>>> let label6 = Label :: Label "6" +-} --- Public constructors for labels +data Lbl (x :: HNat) (ns :: *) (desc :: *) -- labels are exclusively type-level entities +#if !OLD_TYPEABLE + deriving Typeable +#else +instance (ShowLabel x) => Typeable2 (Lbl x) where + typeOf2 _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Label3" "Lbl") + [mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label x))) + []] +#endif +type instance ZipTagged (Lbl ix ns n ': ts) (v ': vs) = Tagged (Lbl ix ns n) v ': ZipTagged ts vs + +instance (Label t ~ Label (Lbl ix ns n)) => SameLabels (Label t) (Lbl ix ns n) + +-- * Public constructors for labels + -- | Construct the first label firstLabel :: ns -> desc -> Label (Lbl HZero ns desc) -firstLabel = undefined +firstLabel _ _ = Label -- | Construct the next label nextLabel :: Label (Lbl x ns desc) -> desc' -> Label (Lbl (HSucc x) ns desc') -nextLabel = undefined +nextLabel _ _ = Label -- | Equality on labels (descriptions are ignored) @@ -57,7 +78,7 @@ {- instance ( HEq x x' b , HEq ns ns' b' - , bres ~ HAnd b b' + , bres ~ HAnd b b' ) => HEq (Lbl x ns desc) (Lbl x' ns' desc') bres -} @@ -67,11 +88,80 @@ instance Show desc => ShowLabel (Lbl x ns desc) where showLabel = show . getd where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs - getd = undefined + getd = error "Data.HList.Label3 desc" instance Show desc => Show (Label (Lbl x ns desc)) where show = show . getd where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs - getd = undefined + getd = error "Data.HList.Label3 desc" + + +{- | + +If possible, Label is left off: + +>>> let q = label3 .*. label3 .*. emptyProxy +>>> :t q +q :: Proxy '[Lbl 'HZero () (), Lbl 'HZero () ()] + +-} +instance HExtend (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs)) where + type HExtendR (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs)) + = Proxy (Lbl n ns desc ': Lbl n' ns' desc' ': xs) + (.*.) _ _ = Proxy + +{- | Mixing two label kinds means we have to include 'Label': + +>>> let r = label3 .*. label6 .*. emptyProxy +>>> :t r +r :: Proxy '[Label (Lbl 'HZero () ()), Label "6"] + +-} +instance HExtend (Label (Lbl n ns desc)) (Proxy (x ': xs :: [Symbol])) where + type HExtendR (Label (Lbl n ns desc)) (Proxy (x ': xs)) + = Proxy (Label (Lbl n ns desc) ': MapLabel (x ': xs)) + (.*.) _ _ = Proxy + +{- | Mixing two label kinds means we have to include 'Label': + +>>> let s = label6 .*. label3 .*. emptyProxy +>>> :t s +s :: Proxy '[Label "6", Label (Lbl 'HZero () ())] + +-} +instance HExtend (Label (y :: Symbol)) (Proxy ((x :: *) ': xs)) where + type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Symbol)) (Proxy ((x :: Nat) ': xs)) where + type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Nat)) (Proxy ((x :: *) ': xs)) where + type HExtendR (Label (y :: Nat)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Nat)) (Proxy ((x :: Symbol) ': xs)) where + type HExtendR (Label (y :: Nat)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +-- | similar to Data.HList.Record.Labels1, but avoids producing Label (Label x) +type family MapLabel (xs :: [k]) :: [*] +type instance MapLabel '[] = '[] +#if NO_CLOSED_TF +-- if we can't have any overlap in the TF (ghc-7.6), cover the Label3/Label6 case +type instance MapLabel ((x :: Symbol) ': xs) = Label x ': MapLabel xs +type instance MapLabel (Lbl n ns desc ': xs) = Label (Lbl n ns desc) ': MapLabel xs +type instance MapLabel (Label x ': xs) = Label x ': MapLabel xs +#else +type instance MapLabel (x ': xs) = AddLabel x ': MapLabel xs +type family AddLabel (x :: k) :: * where + AddLabel (Label x) = Label x + AddLabel x = Label x +#endif diff --git a/Data/HList/Label5.hs b/Data/HList/Label5.hs new file mode 100644 --- /dev/null +++ b/Data/HList/Label5.hs @@ -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) diff --git a/Data/HList/Label6.hs b/Data/HList/Label6.hs --- a/Data/HList/Label6.hs +++ b/Data/HList/Label6.hs @@ -12,7 +12,7 @@ Labels are promoted Strings or Integers "GHC.TypeLits" inside the 'Label'. Needs ghc7.6 or higher. - See "Data.HList.CommonMain#label6demo" for an example. + See for an example. -} @@ -20,11 +20,36 @@ import Data.HList.FakePrelude import GHC.TypeLits +import Data.HList.HListPrelude #if MIN_VERSION_base(4,7,0) instance KnownSymbol x => ShowLabel (x :: Symbol) where showLabel _ = symbolVal (Proxy :: Proxy x) +instance KnownNat x => ShowLabel (x :: Nat) where + showLabel _ = show $ natVal (Proxy :: Proxy x) #else instance SingI x => ShowLabel (x :: Symbol) where showLabel _ = fromSing (sing :: Sing x) + +instance SingI x => ShowLabel (x :: Nat) where + showLabel _ = show (fromSing (sing :: Sing x)) #endif + + + +{- | + +>>> let labelX = Label :: Label "x" +>>> let labelY = Label :: Label "y" +>>> let p = labelX .*. labelY .*. emptyProxy +>>> :t p +p :: Proxy '["x", "y"] + +-} +instance HExtend (Label (y :: Symbol)) (Proxy (x ': xs :: [Symbol])) where + type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Nat)) (Proxy (x ': xs :: [Nat])) where + type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs) + (.*.) _ _ = Proxy diff --git a/Data/HList/Labelable.hs b/Data/HList/Labelable.hs --- a/Data/HList/Labelable.hs +++ b/Data/HList/Labelable.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {- | -Description : labels which are also lenses +Description : labels which are also lenses (or prisms) A simple problem is being solved here, but unfortunately it -is a bit involved. The idea is to use the same haskell identifier +is a bit involved. The idea is to use the same haskell identifier for a lens and for other purposes. In other words, get the same behavior as: @@ -20,125 +18,204 @@ Elaboration of some ideas from edwardk. -} module Data.HList.Labelable - (makeLabelable, - Labelable(hLens'), + (Labelable(..), + LabeledOptic, (.==.), + + -- * multiple lookups + Projected(..), projected', + -- * comparison with 'hLens' -- $comparisonWithhLensFunction -- * likely unneeded (re)exports - -- $note needed to make a needed instance visible - Labeled(Labeled), - toLabel, + LabeledCxt1, + LabeledTo(LabeledTo), + LabeledR(LabeledR), + ToSym, EnsureLabel(toLabel), toLabelSym, Identity, - ToSym, + LabelableTIPCxt, + LabeledOpticType(..), + + LabeledOpticF, + LabeledOpticP, + LabeledOpticTo, ) where + +import Data.HList.HListPrelude import Data.HList.FakePrelude -import Data.HList.HArray -import Data.HList.HList import Data.HList.Record +import Data.HList.Variant +import Data.HList.TIP +import Data.HList.TIC +import Data.HList.Label3 import Control.Monad.Identity import GHC.TypeLits +import LensDefs +import GHC.Exts (Constraint) -import Language.Haskell.TH +{- | This alias is the same as Control.Lens.Optic, except the (->) in Optic +is a type parameter 'to' in LabeledOptic. -{- | @f s t a b@ type parameters are the same as those that make -"Control.Lens" work. +Depending on the collection type (see instances of 'LabelableTy'), +the type variables @to, p, f@ are constrained such that the resulting +type is a @Lens (r s) (r t) a b@, @Prism (r s) (r t) a b@ or a +@LabeledTo x _ _@. The latter can be used to recover the label (@x@) when +used as an argument to '.==.' or equivalently 'toLabel'. +-} +type LabeledOptic (x :: k) (r :: [*] -> *) (s :: [*]) (t :: [*]) (a :: *) (b :: *) + = forall ty to p f. + (ty ~ LabelableTy r, + LabeledOpticF ty f, + LabeledOpticP ty p, + LabeledOpticTo ty x to) => (a `p` f b) `to` (r s `p` f (r t)) -[@n@] is the index in the HList at which the value will be found +data LabeledOpticType = LabelableLens | LabelablePrism | LabelableLabel -[@l@] is the label for the field (tends to be 'GHC.TypeLits.Symbol') +type family LabeledOpticF (ty :: LabeledOpticType) :: (* -> *) -> Constraint +type instance LabeledOpticF LabelableLens = Functor +type instance LabeledOpticF LabelablePrism = Applicative +type instance LabeledOpticF LabelableLabel = (~) Identity -[@p@] is @->@ when the result is used as a lens, or 'Labeled' when used - as an argument to '.==.' +type family LabeledOpticP (ty :: LabeledOpticType) :: (* -> * -> *) -> Constraint +type instance LabeledOpticP LabelableLens = (~) (->) +type instance LabeledOpticP LabelablePrism = Choice +type instance LabeledOpticP LabelableLabel = (~) (->) --} -class Labelable l p f s t a b -#if MIN_VERSION_base(4,7,0) - {- no fundeps in this case: they are potentially inconsistent - according to ghc-7.8 - +type family LabeledOpticTo (ty :: LabeledOpticType) (x :: k) :: (* -> * -> *) -> Constraint +type instance LabeledOpticTo LabelableLens x = (~) (->) +type instance LabeledOpticTo LabelablePrism x = (~) (->) +type instance LabeledOpticTo LabelableLabel x = (~) (LabeledTo x) - these fundeps are mostly documentation, since the two - instances have contexts that encode roughly the same - dependencies provided you choose a specific `p' - -} -#else - | l s -> a, l t -> b, -- lookup - l s b -> t, l t a -> s -- update -#endif + +{- | + +[@r@] is 'Record', 'Variant'. 'TIP' and 'TIC' also have instances, but generally +'tipyLens'' and 'ticPrism'' are more appropriate. + +[@x@] is the label for the field. It tends to have kind 'GHC.TypeLits.Symbol', +but others are supported in principle. + +-} +class SameLength s t => Labelable (x :: k) (r :: [*] -> *) s t a b + | x s -> a, x t -> b, -- lookup + x s b -> t, x t a -> s -- update where - hLens' :: Label l -> p (a -> f b) (Record s -> f (Record t)) + type LabelableTy r :: LabeledOpticType + hLens' :: Label x -> LabeledOptic x r s t a b -data Labeled (l :: k) (a :: *) (b :: *) = Labeled deriving (Show) +data LabeledTo (x :: k) (a :: *) (b :: *) = LabeledTo deriving (Show) --- | make a lens -instance (Functor f, - HasField x (Record s) a, - HasField x (Record t) b, - HFind x (RecordLabels t) n, - HFind x (RecordLabels s) n, - HUpdateAtHNat n (Tagged x b) s, - t ~ HUpdateAtHNatR n (Tagged x b) s) - => Labelable x (->) f s t a b where - hLens' lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab)) +data LabeledR (x :: [*]) = LabeledR --- | make a data type that allows recovering the field name -instance (f ~ Identity, s ~ '[], t ~ '[], a ~ (), b ~ (), - x' ~ x) => Labelable x' (Labeled x) f s t a b where - hLens' _ = Labeled :: Labeled x (a -> f b) (Record s -> f (Record t)) +{- if __GLASGOW_HASKELL__ > 800 +-- should this orphan instance really be supplied? ghc 8's +-- -XOverloadedLabels is uglier syntax than HListPP, and it +-- seems likely that other users of IsLabel probably define +-- an instance for (->) which will be chosen over this one +-- when labels are composed with (.), +-- (or alternatively there will be complaints about overlap) +instance (x ~ x', Labelable x r s t a b) => IsLabel x (LabeledOptic x' r s t a b) where + fromLabel _ = hLens' (Label :: Label x) +-- endif +-} +-- | make a @Lens (Record s) (Record t) a b@ +instance HLens x Record s t a b + => Labelable x Record s t a b where + type LabelableTy Record = LabelableLens + hLens' x = hLens x + +-- | used with 'toLabel' and/or '.==.' +instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where + type LabelableTy LabeledR = LabelableLabel + hLens' _ = LabeledTo + +-- | sets all type variables to dummy values: only the @Labeled x@ +-- part is actually needed +type LabeledCxt1 s t a b = (s ~ '[], t ~ '[], a ~ (), b ~ ()) + +-- | make a @Prism (Variant s) (Variant t) a b@ +instance (HPrism x s t a b, + to ~ (->)) => Labelable x Variant s t a b where + type LabelableTy Variant = LabelablePrism + hLens' x s = hPrism x s + +-- | @hLens' :: Label a -> Prism' (TIC s) a@ +-- +-- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@, +-- cannot have an instance of Labelable +-- +-- Note: `x :: k` according to the instance head, but the instance body +-- forces the kind variable to be * later on. IE. (k ~ *) +instance (TICPrism s t a b, Label x ~ Label a,a ~ b, s ~ t, + SameLength s t) => + Labelable (x :: k) TIC s t a b where + type LabelableTy TIC = LabelablePrism + hLens' _ = ticPrism + + +-- | make a @Lens' (TIP s) a@. +-- +-- 'tipyLens' provides a @Lens (TIP s) (TIP t) a b@, which tends to need +-- too many type annotations to be practical +instance LabelableTIPCxt x s t a b => + Labelable (x :: k) TIP s t a b where + type LabelableTy TIP = LabelableLens + hLens' x = hLens x + +type LabelableTIPCxt x s t a b = + (s ~ t, a ~ b, Label x ~ Label a, + HLens x TIP s t a b) + + -- | modification of '.=.' which works with the labels from this module, -- and those from "Data.HList.Label6". Note that this is not strictly a -- generalization of '.=.', since it does not work with labels like -- "Data.HList.Label3" which have the wrong kind. l .==. v = toLabel l .=. v +infixr 4 .==. --- | extracts the type that is actually the label in @a@ and puts it in @b@ -class ToSym a b +-- | Get the Symbol out of a 'Label' or 'LabeledTo' +class ToSym label (s :: Symbol) | label -> s --- | for labels in this module -instance (x ~ x', p ~ Labeled x') => ToSym (p a b) x' +instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3 + => ToSym (v1 v2 v3) x --- | for "Data.HList.Label6" labels -instance (x ~ x') => ToSym (Label x) x' +instance ToSym (label x) x -toLabel :: ToSym t t' => t -> Label (t' :: Symbol) -toLabel _ = Label +{- | Convert a type to @Label :: Label blah@ +> toLabel :: LabeledTo x _ _ -> Label (x :: Symbol) +> toLabel (hLens' lx) = (lx :: Label x) +> toLabel :: Label x -> Label x +> toLabel :: Proxy x -> Label x +-} +class EnsureLabel x y | x -> y where + toLabel :: x -> y -{- | @makeLabelable \"x y z\"@ will generate haskell identifiers that work with '.==.' and -are also lenses. +instance EnsureLabel (Label x) (Label (x :: k)) where + toLabel _ = Label -> x = hLens' (Label :: Label "x") -> y = hLens' (Label :: Label "y") -> z = hLens' (Label :: Label "z") +instance EnsureLabel (Proxy x) (Label (x :: k)) where + toLabel _ = Label --} -makeLabelable :: String -> Q [Dec] -makeLabelable xs = fmap concat $ mapM makeLabel1 (words xs) - where - -- a bit indirect, ghc-7.6 TH is a bit too eager to reject - -- mis-matched kind variables - makeLabel1 x = sequence - [ - sigD (mkName x) makeSig, - valD (varP (mkName x)) (normalB (varE 'hLens' `appE` lt)) - [] - ] - where lt = [| Label :: $([t| Label $l |]) |] - l = litT (strTyLit x) +-- | get the Label out of a 'LabeledTo' (ie. `foobar when using HListPP). +instance ToSym (a b c) (x :: Symbol) => EnsureLabel (a b c) (Label x) where + toLabel _ = Label - makeSig = [t| Labelable $l p f s t a b => p (a -> f b) (Record s -> f (Record t)) |] +-- | fix the `k` kind variable to 'Symbol' +toLabelSym label = toLabel label `asTypeOf` (Label :: Label (x :: Symbol)) + {- $comparisonWithhLensFunction Note that passing around variables defined with 'hLens'' doesn't get @@ -159,10 +236,120 @@ > -- with the x defined as x = Label :: Label "x" > let f x r = let > a = r ^. hLens x - > b = r & hLens x .~ "6" + > b = r & hLens x .~ "7" > in (a,b) It may work to use 'hLens'' instead of 'hLens' in the second code, but that is a bit beside the point being made here. +The same points apply to the use of 'hPrism' over 'hLens''. + -} + +{- | Sometimes it may be more convenient to operate on a record/variant +that only contains the fields of interest. 'projected' can then be used +to apply that function to a record that contains additional elements. + + +>>> :set -XViewPatterns +>>> import Data.HList.RecordPuns +>>> let f [pun| (x y) |] = case x+y of z -> [pun| z |] +>>> :t f +f :: Num v => + Record '[Tagged "x" v, Tagged "y" v] -> Record '[Tagged "z" v] + +>>> let r = (let x = 1; y = 2; z = () in [pun| x y z |]) +>>> r +Record{x=1,y=2,z=()} + +>>> r & sameLabels . projected %~ f +Record{x=1,y=2,z=3} + + + + +-} +class Projected r s t a b where + projected :: (ty ~ LabelableTy r, + LabeledOpticP ty p, + LabeledOpticF ty f) => r a `p` f (r b) -> r s `p` f (r t) + +-- | @Lens rs rt ra rb@ +-- +-- where @rs ~ Record s, rt ~ Record t, ra ~ Record a, rb ~ Record b@ +instance (-- for Record s -> Record a + H2ProjectByLabels (LabelsOf a) s a_ _s_minus_a, + HRLabelSet a_, HRLabelSet a, + HRearrange (LabelsOf a) a_ a, + + HLeftUnion b s bs, HRLabelSet bs, + HRearrange (LabelsOf t) bs t, HRLabelSet t + ) => Projected Record s t a b where + projected f s = (\b -> hRearrange' (b .<++. s)) <$> f (hProjectByLabels' s :: Record a) + +-- | @Prism (Variant s) (Variant t) (Variant a) (Variant b)@ +instance (ExtendsVariant b t, + ProjectVariant s a, + ProjectExtendVariant s t, + + HLeftUnion b s bs, HRLabelSet bs, + HRearrange (LabelsOf t) bs t) + => Projected Variant s t a b where + projected = prism extendsVariant + (\s -> case projectVariant s of + Just a -> Right a + Nothing | Just t <- projectExtendVariant s -> Left t + _ -> error "Data.HList.Labelable.projected impossible" + -- projectExtendVariant gives Nothing when the element of + -- `t` that is actually stored in the variant comes + -- from the `b`. But in that case the projectVariant + -- above must have been Just + ) + + +{- | @Lens' (Record s) (Record a)@ + +@Prism' (Variant s) (Variant a)@ +-} +projected' s = isSimple projected s + + +{- | Together with the instance below, this allows writing + +@ +'makeLabelable' "x y z" +p = x .*. y .*. z .*. 'emptyProxy' +@ + +Or with HListPP + +@ +p = `x .*. `y .*. `z .*. emptyProxy +@ + +instead of + +> p = Proxy :: Proxy ["x","y","z"] + +-} +instance (to ~ LabeledTo x, ToSym (to p q) x) + => HExtend (to p q) (Proxy ('[] :: [*])) where + type HExtendR (to p q) (Proxy ('[] :: [*])) = Proxy '[GetXFromLabeledTo to] + (.*.) _ _ = Proxy + +instance (to ~ LabeledTo x, ToSym (to p q) x) + => HExtend (to p q) (Proxy (x ': xs)) where + type HExtendR (to p q) (Proxy (x ': xs)) = Proxy (GetXFromLabeledTo to ': x ': xs) + (.*.) _ _ = Proxy + +-- | if the proxy has Data.HList.Label3."Lbl", then everything has to be +-- wrapped in Label to make the kinds match up. +instance (to ~ LabeledTo x, ToSym (to p q) x) + => HExtend (to p q) (Proxy (Lbl n ns desc ': xs)) where + type HExtendR (to p q) (Proxy (Lbl n ns desc ': xs)) + = Proxy (Label (GetXFromLabeledTo to) ': MapLabel (Lbl n ns desc ': xs)) + (.*.) _ _ = Proxy + +type family GetXFromLabeledTo (to :: * -> * -> *) :: Symbol +type instance GetXFromLabeledTo (LabeledTo x) = x + diff --git a/Data/HList/MakeLabels.hs b/Data/HList/MakeLabels.hs --- a/Data/HList/MakeLabels.hs +++ b/Data/HList/MakeLabels.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {- | Description : Automate some of the ways to make labels. @@ -7,12 +8,16 @@ module Data.HList.MakeLabels ( makeLabels, makeLabels3, + + -- * labels using kind 'Symbol' makeLabels6, - -- | see also 'Data.HList.Labelable.makeLabelable' + makeLabelable, ) where +import Data.Typeable import Data.HList.FakePrelude import Data.HList.Label3 +import Data.HList.Labelable import Language.Haskell.TH import Data.Char @@ -30,7 +35,14 @@ c = make_cname n d = make_dname n - dd = dataD (return []) c [] [] [{- 'Typeable -}] + dd = +#if MIN_VERSION_template_haskell(2,12,0) + dataD (return []) c [] Nothing [] [derivClause Nothing [ [t| Typeable |] ]] +#elif MIN_VERSION_template_haskell(2,11,0) + dataD (return []) c [] Nothing [] (fmap (:[]) [t| Typeable |]) +#else + dataD (return []) c [] [] [''Typeable] +#endif labelSig = sigD d [t| Label $(conT c) |] @@ -39,13 +51,6 @@ (normalB [| Label |]) [] - showLabelInst = instanceD - (return []) - [t| ShowLabel $(conT c) |] - [valD (varP 'showLabel) - (normalB [| \_ -> n |]) - [] ] - showInst = instanceD (return []) [t| Show $(conT c) |] @@ -59,13 +64,12 @@ dd, - showLabelInst, showInst ] {- | -Labels like "Data.HList.Label4" used to provide (only no Typeable). +Labels like "Data.HList.Label5". The following TH declaration splice should be placed at top-level, before the created values are used. Enable @-XTemplateHaskell@ too. @@ -74,21 +78,16 @@ should expand into the following declarations -> data LabelGetX -> data LabelGetY -> data LabelDraw -> data LabelX +> data LabelGetX deriving Typeable +> data LabelGetY deriving Typeable +> data LabelDraw deriving Typeable +> data LabelX deriving Typeable > getX = Label :: Label LabelGetX > getY = Label :: Label LabelGetY > draw = Label :: Label LabelDraw > x = Label :: Label LabelX - -> instance ShowLabel LabelGetX where showLabel = \_ -> "getX" -> instance ShowLabel LabelGetY where showLabel = \_ -> "getY" -> instance ShowLabel LabelDraw where showLabel = \_ -> "draw" - -} makeLabels :: [String] -> Q [Dec] makeLabels = fmap concat . mapM dcl @@ -117,8 +116,45 @@ -- possibly there is a better option makeLabels3 ns [] = fail ("makeLabels3 "++ ns ++ " []") --- | for "Data.HList.Label6" +{- | for "Data.HList.Label6" + +> makeLabels6 ["x","y"] + +is a shortcut for + +> x = Label :: Label "x" +> y = Label :: Label "y" + +-} makeLabels6 :: [String] -> Q [Dec] makeLabels6 ns = fmap concat $ forM ns $ \n -> sequence [sigD (make_dname n) [t| Label $(litT (strTyLit n)) |], valD (varP (make_dname n)) (normalB [| Label |]) []] + + +{- | @makeLabelable \"x y z\"@ expands out to + +> x = hLens' (Label :: Label "x") +> y = hLens' (Label :: Label "y") +> z = hLens' (Label :: Label "z") + +Refer to "Data.HList.Labelable" for usage. + +-} +makeLabelable :: String -> Q [Dec] +makeLabelable xs = fmap concat $ mapM makeLabel1 (words xs) + where + -- a bit indirect, ghc-7.6 TH is a bit too eager to reject + -- mis-matched kind variables + makeLabel1 x = sequence + [ + sigD (mkName x) makeSig, + valD (varP (mkName x)) (normalB (varE 'hLens' `appE` lt)) + [] + ] + where lt = [| Label :: $([t| Label $l |]) |] + l = litT (strTyLit x) + + makeSig = [t| forall r s t a b. (Labelable $l r s t a b) => + LabeledOptic $l r s t a b + |] diff --git a/Data/HList/Record.hs b/Data/HList/Record.hs --- a/Data/HList/Record.hs +++ b/Data/HList/Record.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} {- | The HList library @@ -10,9 +10,13 @@ * "Data.HList.Label3" - * "Data.HList.MakeLabels" + * "Data.HList.Label5" + * "Data.HList.Label6" + * "Data.HList.Labelable" + + These used to work: * "Data.HList.Label1" @@ -21,8 +25,6 @@ * "Data.HList.Label4" - * "Data.HList.Label5" - -} module Data.HList.Record @@ -35,24 +37,34 @@ -- ** Labels -- $labels module Data.Tagged, - (.=.), (.-.), + (.=.), -- ** Record Record(..), mkRecord, emptyRecord, + hEndR, + hEndP, - -- *** Getting Labels - RecordLabels, - recordLabels, + hListRecord, hListRecord', + -- *** Getting Labels LabelsOf, - hLabels, + labelsOf, + asLabelsOf, -- *** Getting Values RecordValues(..), recordValues, + hMapTaggedFn, + unlabeled0, + + Unlabeled, + unlabeled, + Unlabeled', + unlabeled', + -- * Operations -- ** Show -- | A corresponding 'Show' instance exists as @@ -61,42 +73,53 @@ ShowComponents(..), ShowLabel(..), + -- ** Extension + -- | 'hExtend', 'hAppend' + (.*.), -- ** Delete -- | 'hDeleteAtLabel' @label record@ - hDeleteAtLabel, + (.-.), + HDeleteLabels(..), -- ** Lookup/update -- $lens - hLens, + HLens(hLens), -- ** Lookup HasField(..), - HasField'(..), + HasFieldM(..), (.!.), -- ** Update (.@.), - hUpdateAtLabel, + HUpdateAtLabel(hUpdateAtLabel), -- *** type-preserving versions - -- $note these restrict the resulting record type to be the same as in + -- | Note: these restrict the resulting record type to be the same as in -- input record type, which can help reduce the number of type annotations -- needed (.<.), + HTPupdateAtLabel, hTPupdateAtLabel, -- ** Rename Label hRenameLabel, -- ** Projection + + Labels, + -- $projection hProjectByLabels, + hProjectByLabels', hProjectByLabels2, + -- *** a lens for projection + -- | see "Data.HList.Labelable".'Projected' + -- ** Unions -- *** Left HLeftUnion(hLeftUnion), - HLeftUnionBool(hLeftUnionBool), (.<++.), -- *** Symmetric @@ -106,40 +129,78 @@ -- ** Reorder Labels hRearrange, + hRearrange', - -- ** Extension - -- | 'hExtend', 'hAppend' - (.*.), + -- *** isos using hRearrange + Rearranged(rearranged), rearranged', + -- ** Apply a function to all values + hMapR, HMapR(..), + + -- ** cast labels + Relabeled(relabeled), + relabeled', + -- * Hints for type errors DuplicatedLabel, - ExtraField(..), - FieldNotFound(..), + ExtraField, + FieldNotFound, -- * Unclassified + -- | Probably internals, that may not be useful +#if __GLASGOW_HASKELL__ != 706 + zipTagged, +#endif + HasField'(..), + DemoteMaybe, + HasFieldM1(..), H2ProjectByLabels(h2projectByLabels), H2ProjectByLabels'(h2projectByLabels'), HLabelSet, HLabelSet', HRLabelSet, - HRLabelSet', + HAllTaggedLV, HRearrange(hRearrange2), - HRearrange'(hRearrange2'), + HRearrange3(hRearrange3), + HRearrange4(hRearrange4), UnionSymRec'(..), + HFindLabel, labelLVPair, newLVPair, + UnLabel, + HMemberLabel, + TaggedFn(..), + ReadComponent, + HMapTaggedFn, + HLensCxt, + + -- ** zip + -- | use the more general 'HZip' class instead + HZipRecord(..), + -- *** alternative implementation + hZipRecord2, hUnzipRecord2 ) where import Data.HList.FakePrelude import Data.HList.HListPrelude import Data.HList.HList -import Data.HList.HArray +import Data.HList.Label3 (MapLabel) + import Data.Tagged - +import Control.Monad + +import Text.ParserCombinators.ReadP + +import LensDefs + +import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif -- imports for doctest/examples import Data.HList.Label6 () import Data.HList.TypeEqO () @@ -187,46 +248,122 @@ l .=. v = newLVPair l v -newtype Record (r :: [*]) = Record (HList r) -- deriving Eq +newtype Record (r :: [*]) = Record (HList r) +deriving instance Semigroup (HList r) => Semigroup (Record r) +deriving instance Monoid (HList r) => Monoid (Record r) +deriving instance (Eq (HList r)) => Eq (Record r) +deriving instance (Ord (HList r)) => Ord (Record r) +deriving instance (Ix (HList r)) => Ix (Record r) +deriving instance (Bounded (HList r)) => Bounded (Record r) + -- | Build a record mkRecord :: HRLabelSet r => HList r -> Record r mkRecord = Record +-- | @HRLabelSet t => Iso (HList s) (HList t) (Record s) (Record t)@ +hListRecord x = isoNewtype mkRecord (\(Record r) -> r) x +-- | @Iso' (HList s) (Record s)@ +hListRecord' x = isSimple hListRecord x + -- | Build an empty record emptyRecord :: Record '[] emptyRecord = mkRecord HNil +-- | @Iso (Record s) (Record t) (HList a) (HList b)@ +-- +-- @view unlabeled == 'recordValues'@ +unlabeled0 x = sameLabels (iso recordValues hMapTaggedFn x) --- | Propery of a proper label set for a record: no duplication of labels +unlabeled :: (Unlabeled x y, Profunctor p, Functor f) => + (HList (RecordValuesR x) `p` f (HList (RecordValuesR y))) -> + (Record x `p` f (Record y)) +unlabeled x = sameLength (unlabeled0 (sameLength x)) + +type Unlabeled x y = + (HMapCxt HList TaggedFn (RecordValuesR y) y, + RecordValues x, RecordValues y, + SameLength (RecordValuesR x) (RecordValuesR y), + SameLength x y, SameLabels x y, + HAllTaggedLV x, HAllTaggedLV y) +type Unlabeled' x = Unlabeled x x + + + +-- | @Unlabeled' x => Iso' (Record x) (HList (RecordValuesR x))@ +unlabeled' :: (Unlabeled' x, Profunctor p, Functor f) => + (HList (RecordValuesR x) `p` f (HList (RecordValuesR x))) -> + (Record x `p` f (Record x)) +unlabeled' = unlabeled + +{- | @Iso (Record s) (Record t) (Record a) (Record b)@, such that +@relabeled = unlabeled . from unlabeled@ + +in other words, pretend a record has different labels, but the same values. + +-} +class Relabeled r where + relabeled :: forall p f s t a b. + (HMapTaggedFn (RecordValuesR s) a, + HMapTaggedFn (RecordValuesR b) t, + SameLengths '[s,a,t,b], + RecordValuesR t ~ RecordValuesR b, + RecordValuesR s ~ RecordValuesR a, + RecordValues b, RecordValues s, + Profunctor p, + Functor f + ) => r a `p` f (r b) -> r s `p` f (r t) + +instance Relabeled Record where + relabeled = iso + (\ s -> hMapTaggedFn (recordValues s)) + (\ b -> hMapTaggedFn (recordValues b)) + -- isoNewtype should be safe here, but there are no guarantees + -- http://stackoverflow.com/questions/24222552 + +-- | @Iso' (Record s) (Record a)@ +-- +-- such that @RecordValuesR s ~ RecordValuesR a@ +relabeled' x = isSimple relabeled x + +data TaggedFn = TaggedFn +instance (tx ~ Tagged t x) => ApplyAB TaggedFn x tx where + applyAB _ = Tagged + +type HMapTaggedFn l r = + (HMapCxt HList TaggedFn l r, + RecordValuesR r ~ l, + RecordValues r) + +-- | \"inverse\" to 'recordValues' +hMapTaggedFn :: HMapTaggedFn a b => HList a -> Record b +hMapTaggedFn = Record . hMap TaggedFn + +-- | Property of a proper label set for a record: no duplication of labels, +-- and every element of the list is @Tagged label value@ + data DuplicatedLabel l -class HRLabelSet (ps :: [*]) -instance HRLabelSet '[] -instance HRLabelSet '[x] -instance ( HEq l1 l2 leq - , HRLabelSet' l1 l2 leq r - ) => HRLabelSet (Tagged l1 v1 ': Tagged l2 v2 ': r) +class (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*]) +instance (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*]) -class HRLabelSet' l1 l2 (leq::Bool) (r :: [*]) -instance ( HRLabelSet (Tagged l2 () ': r) - , HRLabelSet (Tagged l1 () ': r) - ) => HRLabelSet' l1 l2 False r -instance ( Fail (DuplicatedLabel l1) ) => HRLabelSet' l1 l2 True r --- | Relation between HLabelSet and HRLabelSet -{- -instance (HZip ls vs ps, HLabelSet ls) => HRLabelSet ps + +{- | Relation between HLabelSet and HRLabelSet + +> instance HLabelSet (LabelsOf ps) => HRLabelSet ps + +see also 'HSet' -} class HLabelSet ls instance HLabelSet '[] instance HLabelSet '[x] -instance ( HEq l1 l2 leq +instance ( HEqK l1 l2 leq , HLabelSet' l1 l2 leq r ) => HLabelSet (l1 ': l2 ': r) @@ -236,40 +373,53 @@ ) => HLabelSet' l1 l2 False r instance ( Fail (DuplicatedLabel l1) ) => HLabelSet' l1 l2 True r --- | Construct the (phantom) list of labels of the record. --- +-- | Construct the (phantom) list of labels of a record, +-- or list of Label. +type family LabelsOf (ls :: [*]) :: [*] +type instance LabelsOf '[] = '[] +type instance LabelsOf (Label l ': r) = Label l ': LabelsOf r +type instance LabelsOf (Tagged l v ': r) = Label l ': LabelsOf r -type family RecordLabels (r :: [*]) :: [k] -type instance RecordLabels '[] = '[] -type instance RecordLabels (Tagged l v ': r) = l ': RecordLabels r +labelsOf :: hlistOrRecord l -> Proxy (LabelsOf l) +labelsOf _ = Proxy -recordLabels :: Record r -> Proxy (RecordLabels r) -recordLabels _ = Proxy +-- | remove the Label type constructor. The @proxy@ argument is +-- supplied to make it easier to fix the kind variable @k@. +type family UnLabel (proxy :: k) (ls :: [*]) :: [k] +type instance UnLabel proxy (Label x ': xs) = x ': UnLabel proxy xs +type instance UnLabel proxy '[] = '[] + +-- | A version of 'HFind' where the @ls@ type variable is a list of +-- 'Tagged' or 'Label'. This is a bit indirect, and ideally LabelsOf +-- could have kind [*] -> [k]. +type HFindLabel (l :: k) (ls :: [*]) (n :: HNat) = HFind l (UnLabel l (LabelsOf ls)) n + -- | Construct the HList of values of the record. -class RecordValues (r :: [*]) where +class SameLength r (RecordValuesR r) + => RecordValues (r :: [*]) where type RecordValuesR r :: [*] recordValues' :: HList r -> HList (RecordValuesR r) instance RecordValues '[] where type RecordValuesR '[] = '[] recordValues' _ = HNil -instance RecordValues r=> RecordValues (Tagged l v ': r) where +instance (SameLength' r (RecordValuesR r), + SameLength' (RecordValuesR r) r, RecordValues r) => RecordValues (Tagged l v ': r) where type RecordValuesR (Tagged l v ': r) = v ': RecordValuesR r recordValues' (HCons (Tagged v) r) = HCons v (recordValues' r) recordValues :: RecordValues r => Record r -> HList (RecordValuesR r) recordValues (Record r) = recordValues' r - --- | Making this ls::[*] and [k] breaks the MainGhcGeneric1.hs... -type family LabelsOf (ls :: [*]) :: [*] -type instance LabelsOf '[] = '[] -type instance LabelsOf (Label l ': r) = l ': LabelsOf r +{- shorter, but worse in terms needing annotations to allow ambiguous types +- but better in terms of inference +recordValues :: RecordValues r rv => Record r -> HList rv +recordValues (Record r) = hMap HUntag r -hLabels :: HList l -> Proxy (LabelsOf l) -hLabels _ = Proxy +type RecordValues r rv = HMapCxt HUntag r rv +-} -- -------------------------------------------------------------------------- @@ -299,15 +449,66 @@ ++ showComponents "," r +-- -------------------------------------------------------------------------- +-- 'Read' instance to appeal to normal records + +data ReadComponent = ReadComponent Bool -- ^ include comma? + +instance (Read v, ShowLabel l, + x ~ Tagged l v, + ReadP x ~ y) => + ApplyAB ReadComponent (Proxy x) y where + applyAB (ReadComponent comma) _ = do + when comma (() <$ string ",") + _ <- string (showLabel (Label :: Label l)) + _ <- string "=" + v <- readS_to_P reads + return (Tagged v) + + +instance (HMapCxt HList ReadComponent (AddProxy rs) bs, + ApplyAB ReadComponent (Proxy r) readP_r, + HProxies rs, + HSequence ReadP (readP_r ': bs) (r ': rs), + readP_r ~ ReadP (Tagged l v), + + -- ghc-8.0.2 needs these. The above constraints + -- should imply them + r ~ Tagged l v, + ShowLabel l, + Read v, + HSequence ReadP bs rs + ) => Read (Record (r ': rs)) where + readsPrec _ = readP_to_S $ do + _ <- string "Record{" + content <- hSequence parsers + _ <- string "}" + return (Record content) + + where + rs :: HList (AddProxy rs) + rs = hProxies + + readP_r :: readP_r + readP_r = applyAB + (ReadComponent False) + (Proxy :: Proxy r) + + parsers = readP_r `HCons` (hMap (ReadComponent True) rs :: HList bs) + + + + + -- -------------------------------------------------------------------------- -- Extension -instance HRLabelSet (Tagged l v ': r) - => HExtend (Tagged (l :: k) v) (Record r) where - type HExtendR (Tagged l v) (Record r) = Record (Tagged l v ': r) +instance HRLabelSet (t ': r) + => HExtend t (Record r) where + type HExtendR t (Record r) = Record (t ': r) f .*. (Record r) = mkRecord (HCons f r) @@ -328,11 +529,11 @@ -- Concatenation -instance (HRLabelSet (HAppendList r1 r2), HAppend (HList r1) (HList r2)) +instance (HRLabelSet (HAppendListR r1 r2), HAppend (HList r1) (HList r2)) => HAppend (Record r1) (Record r2) where hAppend (Record r) (Record r') = mkRecord (hAppend r r') -type instance HAppendR (Record r1) (Record r2) = Record (HAppendList r1 r2) +type instance HAppendR (Record r1) (Record r2) = Record (HAppendListR r1 r2) -- -------------------------------------------------------------------------- -- Lookup @@ -348,7 +549,7 @@ hLookupByLabel:: Label l -> r -> v {- alternative "straightforward" implementation -instance ( RecordLabels r ~ ls +instance ( LabelsOf r ~ ls , HFind l ls n , HLookupByHNat n r , HLookupByHNatR n r ~ LVPair l v @@ -359,14 +560,55 @@ (LVPair v) = hLookupByHNat (proxy :: Proxy n) r -} +{- | a version of 'HasField' / 'hLookupByLabel' / '.!.' that +returns a default value when the label is not in the record: +>>> let r = x .=. "the x value" .*. emptyRecord -instance (HEq l l1 b, HasField' b l (Tagged l1 v1 ': r) v) +>>> hLookupByLabelM y r () +() + +>>> hLookupByLabelM x r () +"the x value" + + + +-} +class HasFieldM (l :: k) r (v :: Maybe *) | l r -> v where + hLookupByLabelM :: Label l + -> r -- ^ Record (or Variant,TIP,TIC) + -> t -- ^ default value + -> DemoteMaybe t v + +type family DemoteMaybe (d :: *) (v :: Maybe *) :: * +type instance DemoteMaybe d (Just a) = a +type instance DemoteMaybe d Nothing = d + +class HasFieldM1 (b :: Maybe [*]) (l :: k) r v | b l r -> v where + hLookupByLabelM1 :: Proxy b -> Label l -> r -> t -> DemoteMaybe t v + +instance (HMemberM (Label l) (LabelsOf xs) b, + HasFieldM1 b l (r xs) v) => HasFieldM l (r xs) v where + hLookupByLabelM = hLookupByLabelM1 (Proxy :: Proxy b) + +instance HasFieldM1 Nothing l r Nothing where + hLookupByLabelM1 _ _ _ t = t + +instance HasField l r v => HasFieldM1 (Just b) l r (Just v) where + hLookupByLabelM1 _ l r _t = hLookupByLabel l r + + + +instance (HEqK l l1 b, HasField' b l (Tagged l1 v1 ': r) v) => HasField l (Record (Tagged l1 v1 ': r)) v where hLookupByLabel l (Record r) = hLookupByLabel' (Proxy::Proxy b) l r +-- | XXX +instance (t ~ Any, Fail (FieldNotFound l ())) => HasField l (Record '[]) t where + hLookupByLabel _ _ = error "Data.HList.Record.HasField: Fail instances should not exist" + class HasField' (b::Bool) (l :: k) (r::[*]) v | b l r -> v where hLookupByLabel':: Proxy b -> Label l -> HList r -> v @@ -417,11 +659,10 @@ -- Delete -hDeleteAtLabel :: forall l t t1 t2. - (H2ProjectByLabels '[l] t t1 t2) => - Label l -> Record t -> Record t2 -hDeleteAtLabel _ (Record r) = - Record $ snd $ h2projectByLabels (Proxy::Proxy '[l]) r +instance (H2ProjectByLabels '[Label l] v t1 v') + => HDeleteAtLabel Record l v v' where + hDeleteAtLabel _ (Record r) = + Record $ snd $ h2projectByLabels (Proxy::Proxy '[Label l]) r infixl 2 .-. {-| @@ -446,8 +687,8 @@ > .-. label1 -} -(.-.) :: (H2ProjectByLabels '[l] r _r' r') => - Record r -> Label l -> Record r' +(.-.) :: (HDeleteAtLabel r l xs xs') => + r xs -> Label l -> r xs' r .-. l = hDeleteAtLabel l r @@ -456,12 +697,54 @@ -- Update -- | 'hUpdateAtLabel' @label value record@ -hUpdateAtLabel :: forall (r :: [*]) (l :: k) (n::HNat) (v :: *). - (HFind l (RecordLabels r) n, HUpdateAtHNat n (Tagged l v) r) => - Label l -> v -> Record r -> Record (HUpdateAtHNatR n (Tagged l v) r) -hUpdateAtLabel l v (Record r) = + +class + HUpdateAtLabel record (l :: k) (v :: *) (r :: [*]) (r' :: [*]) + | l v r -> r', l r' -> v where + hUpdateAtLabel :: SameLength r r' => Label l -> v -> record r -> record r' + +instance (HUpdateAtLabel2 l v r r', + HasField l (Record r') v) => + HUpdateAtLabel Record l v r r' where + hUpdateAtLabel = hUpdateAtLabel2 + +{- alternative impl which reports a Fail constraint that is too long (the +one from HUpdateAtHNat) on ghc 7.10 RC1 + +instance (HasField l (Record r') v, + HFindLabel l r n, + HUpdateAtHNat n (Tagged l v) r, + HUpdateAtHNatR n (Tagged l v) r ~ r', + SameLength r r') => + HUpdateAtLabel Record l v r r' where + hUpdateAtLabel l v (Record r) = Record (hUpdateAtHNat (Proxy::Proxy n) (newLVPair l v) r) +-} +class HUpdateAtLabel2 (l :: k) (v :: *) (r :: [*]) (r' :: [*]) + | l r v -> r' where + hUpdateAtLabel2 :: Label l -> v -> Record r -> Record r' + +class HUpdateAtLabel1 (b :: Bool) (l :: k) (v :: *) (r :: [*]) (r' :: [*]) + | b l v r -> r' where + hUpdateAtLabel1 :: Proxy b -> Label l -> v -> Record r -> Record r' + +instance HUpdateAtLabel1 True l v (Tagged l e ': xs) (Tagged l v ': xs) where + hUpdateAtLabel1 _b _l v (Record (e `HCons` xs)) = Record (e{ unTagged = v } `HCons` xs) + +instance HUpdateAtLabel2 l v xs xs' => HUpdateAtLabel1 False l v (x ': xs) (x ': xs') where + hUpdateAtLabel1 _b l v (Record (x `HCons` xs)) = case hUpdateAtLabel2 l v (Record xs) of + Record xs' -> Record (x `HCons` xs') + +instance (HEqK l l' b, HUpdateAtLabel1 b l v (Tagged l' e ': xs) xs') + => HUpdateAtLabel2 l v (Tagged l' e ': xs) xs' where + hUpdateAtLabel2 = hUpdateAtLabel1 (Proxy :: Proxy b) + +-- | XXX +instance Fail (FieldNotFound l ()) => HUpdateAtLabel2 l v '[] '[] where + hUpdateAtLabel2 _ _ r = r + + infixr 2 .@. {-| @@ -485,24 +768,58 @@ -- | @hProjectByLabels ls r@ returns @r@ with only the labels in @ls@ remaining -hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) => - Proxy ls -> Record t -> Record a +hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) => + proxy ls -> Record t -> Record a hProjectByLabels ls (Record r) = mkRecord (fst $ h2projectByLabels ls r) -- | See 'H2ProjectByLabels' -hProjectByLabels2 :: +hProjectByLabels2 :: (H2ProjectByLabels ls t t1 t2, HRLabelSet t1, HRLabelSet t2) => Proxy ls -> Record t -> (Record t1, Record t2) hProjectByLabels2 ls (Record r) = (mkRecord rin, mkRecord rout) where (rin,rout) = h2projectByLabels ls r +-- need to rearrange because the ordering in the result is determined by +-- the ordering in the original record, not the ordering in the proxy. In +-- other words, +-- +-- > hProjectByLabels (Proxy :: Proxy ["x","y"]) r == hProjectByLabels (Proxy :: Proxy ["y","x"]) r +hProjectByLabels' r = + let r' = hRearrange' (hProjectByLabels (labelsOf r') r) + in r' + + + +{- | A helper to make the Proxy needed by hProjectByLabels, +and similar functions which accept a list of kind [*]. + +For example: + +@(rin,rout) = 'hProjectByLabels2' (Proxy :: Labels ["x","y"]) r@ + +behaves like + +> rin = r .!. (Label :: Label "x") .*. +> r .!. (Label :: Label "y") .*. +> emptyRecord +> +> rout = r .-. (Label :: Label "x") .-. (Label :: Label "y") + +-} +type family Labels (xs :: [k]) :: * +type instance Labels xs = Proxy (Labels1 xs) + +type family Labels1 (xs :: [k]) :: [*] +type instance Labels1 '[] = '[] +type instance Labels1 (x ': xs) = Label x ': Labels1 xs + -- | /Invariant/: -- -- > r === rin `disjoint-union` rout -- > labels rin === ls -- > where (rin,rout) = hProjectByLabels ls r -class H2ProjectByLabels (ls::[k]) r rin rout | ls r -> rin rout where - h2projectByLabels :: Proxy ls -> HList r -> (HList rin,HList rout) +class H2ProjectByLabels (ls::[*]) r rin rout | ls r -> rin rout where + h2projectByLabels :: proxy ls -> HList r -> (HList rin,HList rout) instance H2ProjectByLabels '[] r '[] r where h2projectByLabels _ r = (HNil,r) @@ -510,21 +827,23 @@ instance H2ProjectByLabels (l ': ls) '[] '[] '[] where h2projectByLabels _ _ = (HNil,HNil) -instance (HMemberM l1 ((l::k) ': ls) (b :: Maybe [k]), +instance (HMemberM (Label l1) ((l :: *) ': ls) (b :: Maybe [*]), H2ProjectByLabels' b (l ': ls) (Tagged l1 v1 ': r1) rin rout) => H2ProjectByLabels (l ': ls) (Tagged l1 v1 ': r1) rin rout where h2projectByLabels = h2projectByLabels' (Proxy::Proxy b) -class H2ProjectByLabels' (b::Maybe [k]) (ls::[k]) r rin rout +class H2ProjectByLabels' (b::Maybe [*]) (ls::[*]) r rin rout | b ls r -> rin rout where - h2projectByLabels' :: Proxy b -> Proxy ls -> - HList r -> (HList rin,HList rout) + h2projectByLabels' :: Proxy b -> proxy ls -> + HList r -> (HList rin,HList rout) instance H2ProjectByLabels ls1 r rin rout => H2ProjectByLabels' ('Just ls1) ls (f ': r) (f ': rin) rout where h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout) where (rin,rout) = h2projectByLabels (Proxy::Proxy ls1) r +-- | if ls above has labels not in the record, +-- we get labels (rin `isSubsetOf` ls). instance H2ProjectByLabels ls r rin rout => H2ProjectByLabels' 'Nothing ls (f ': r) rin (f ': rout) where h2projectByLabels' _ ls (HCons x r) = (rin, HCons x rout) @@ -546,12 +865,11 @@ -- -------------------------------------------------------------------------- +type HTPupdateAtLabel record l v r = (HUpdateAtLabel record l v r r, SameLength' r r) + -- | A variation on 'hUpdateAtLabel': type-preserving update. +hTPupdateAtLabel :: HTPupdateAtLabel record l v r => Label l -> v -> record r -> record r hTPupdateAtLabel l v r = hUpdateAtLabel l v r - where - _te :: a -> a -> () - _te _ _ = () - _ = _te v (hLookupByLabel l r) {- ^ @@ -574,40 +892,41 @@ -- -------------------------------------------------------------------------- -- | Subtyping for records -instance H2ProjectByLabels (RecordLabels r2) r1 r2 rout +instance H2ProjectByLabels (LabelsOf r2) r1 r2 rout => SubType (Record r1) (Record r2) +type HMemberLabel l r b = HMember l (UnLabel l (LabelsOf r)) b + -- -------------------------------------------------------------------------- -- Left Union -class HLeftUnion r r' r'' | r r' -> r'' - where hLeftUnion :: Record r -> Record r' -> Record r'' +class HDeleteLabels ks r r' | ks r -> r' + where hDeleteLabels :: proxy (ks :: [*]) -- ^ as provided by labelsOf + -> Record r -> Record r' -instance HLeftUnion r '[] r - where hLeftUnion r _ = r +instance (HMember (Label l) ks b, + HCond b (Record r2) (Record (Tagged l v ': r2)) (Record r3), + HDeleteLabels ks r1 r2) => + HDeleteLabels ks (Tagged l v ': r1) r3 where + hDeleteLabels ks (Record (HCons lv r1)) = + case hDeleteLabels ks (Record r1) of + Record r2 -> hCond (Proxy :: Proxy b) + (Record r2) + (Record (HCons lv r2)) +instance HDeleteLabels ks '[] '[] where + hDeleteLabels _ _ = emptyRecord -instance ( RecordLabels r ~ ls - , HMember l ls b - , HLeftUnionBool b r (Tagged l v) r''' - , HLeftUnion r''' r' r'' - ) - => HLeftUnion r (Tagged l v ': r') r'' - where - hLeftUnion r (Record (HCons f r')) = r'' - where - r''' = hLeftUnionBool (Proxy :: Proxy b) r f - r'' = hLeftUnion (r''' :: Record r''') (Record r' :: Record r') -class HLeftUnionBool (b :: Bool) r f r' | b r f -> r' - where hLeftUnionBool :: Proxy b -> Record r -> f -> Record r' +class HLeftUnion r r' r'' | r r' -> r'' + where hLeftUnion :: Record r -> Record r' -> Record r'' -instance HLeftUnionBool True r f r - where hLeftUnionBool _ r _ = r +instance (HDeleteLabels (LabelsOf l) r r', + HAppend (Record l) (Record r'), + HAppendR (Record l) (Record r') ~ (Record lr)) => HLeftUnion l r lr + where hLeftUnion l r = l `hAppend` hDeleteLabels (labelsOf l) r -instance HLeftUnionBool False r f (f ': r) - where hLeftUnionBool _ (Record r) f = Record (HCons f r) infixl 1 .<++. {-| @@ -651,11 +970,10 @@ class UnionSymRec r1 r2 ru | r1 r2 -> ru where unionSR :: Record r1 -> Record r2 -> (Record ru, Record ru) -instance UnionSymRec r1 '[] r1 where +instance (r1 ~ r1') => UnionSymRec r1 '[] r1' where unionSR r1 _ = (r1, r1) -instance ( RecordLabels r1 ~ ls - , HMember l ls b +instance ( HMemberLabel l r1 b , UnionSymRec' b r1 (Tagged l v) r2' ru ) => UnionSymRec r1 (Tagged l v ': r2') ru @@ -668,29 +986,25 @@ -{- -- | Field f2 is already in r1, so it will be in the union of r1 -- with the rest of r2. -- -- To inject (HCons f2 r2) in that union, we should replace the -- field f2 --} instance (UnionSymRec r1 r2' ru, - HasField l2 (Record ru) v2, - HUpdateAtHNat n (Tagged l2 v2) ru, - ru ~ HUpdateAtHNatR n (Tagged l2 v2) ru, - RecordLabels ru ~ ls, - f2 ~ Tagged l2 v2, - HFind l2 ls n) + HTPupdateAtLabel Record l2 v2 ru, + f2 ~ Tagged l2 v2) => UnionSymRec' True r1 f2 r2' ru where unionSR' _ r1 (Tagged v2) r2' = case unionSR r1 r2' of (ul,ur) -> (ul, hTPupdateAtLabel (Label :: Label l2) v2 ur) + instance (UnionSymRec r1 r2' ru, HExtend f2 (Record ru), - HExtendR f2 (Record ru) ~ Record f2ru) + Record f2ru ~ HExtendR f2 (Record ru) + ) => UnionSymRec' False r1 f2 r2' f2ru where unionSR' _ r1 f2 r2' = (ul', ur') where (ul,ur) = unionSR r1 r2' @@ -699,55 +1013,331 @@ -- -------------------------------------------------------------------------- -- | Rearranges a record by labels. Returns the record r, rearranged such that --- the labels are in the order given by ls. (recordLabels r) must be a +-- the labels are in the order given by ls. (LabelsOf r) must be a -- permutation of ls. -hRearrange :: (HLabelSet ls, HRearrange ls r (HList r')) => Proxy ls -> Record r -> Record r' +hRearrange :: (HLabelSet ls, HRearrange ls r r') => Proxy ls -> Record r -> Record r' hRearrange ls (Record r) = Record (hRearrange2 ls r) +{- | 'hRearrange'' is 'hRearrange' where ordering specified by the Proxy +argument is determined by the result type. + +With built-in haskell records, these @e1@ and @e2@ have the same type: + +> data R = R { x, y :: Int } +> e1 = R{ x = 1, y = 2} +> e2 = R{ y = 2, x = 1} + +'hRearrange'' can be used to allow either ordering to be accepted: + +> h1, h2 :: Record [ Tagged "x" Int, Tagged "y" Int ] +> h1 = hRearrange' $ +> x .=. 1 .*. +> y .=. 2 .*. +> emptyRecord +> +> h2 = hRearrange' $ +> y .=. 2 .*. +> x .=. 1 .*. +> emptyRecord + +-} +hRearrange' r = + let r' = hRearrange (labelsOf r') r + in r' + + +class Rearranged r s t a b where + -- @Iso (r s) (r t) (r a) (r b)@ + rearranged :: (Profunctor p, Functor f) => r a `p` f (r b) -> r s `p` f (r t) + + +{- | @Iso (Record s) (Record t) (Record a) (Record b)@ + +where @s@ is a permutation of @a@, @b@ is a permutation of @t@. +In practice 'sameLabels' and 'sameLength' are likely needed on both +sides of @rearranged@, to avoid ambiguous types. + +An alternative implementation: + +> rearranged x = iso hRearrange' hRearrange' x + +-} +instance (la ~ LabelsOf a, lt ~ LabelsOf t, + HRearrange la s a, + HRearrange lt b t, + HLabelSet la, + HLabelSet lt) + => Rearranged Record s t a b where + rearranged = iso (hRearrange (Proxy :: Proxy la)) + (hRearrange (Proxy :: Proxy lt)) + +{- | @Iso' (r s) (r a)@ + +where @s@ is a permutation of @a@ -} +rearranged' x = isSimple rearranged x + -- | Helper class for 'hRearrange' -class HRearrange ls r r' where - hRearrange2 :: Proxy ls -> HList r -> r' +class (HRearrange3 ls r r', LabelsOf r' ~ ls, + SameLength ls r, SameLength r r') + => HRearrange (ls :: [*]) r r' | ls r -> r', r' -> ls where + hRearrange2 :: proxy ls -> HList r -> HList r' -instance (HList '[] ~ r) => HRearrange '[] '[] r where - hRearrange2 _ _ = HNil +instance (HRearrange3 ls r r', LabelsOf r' ~ ls, + SameLength ls r, SameLength r r') => HRearrange ls r r' where + hRearrange2 = hRearrange3 + +-- | same as HRearrange, except no backwards FD +class HRearrange3 (ls :: [*]) r r' | ls r -> r' where + hRearrange3 :: proxy ls -> HList r -> HList r' + +instance HRearrange3 '[] '[] '[] where + hRearrange3 _ _ = HNil + instance (H2ProjectByLabels '[l] r rin rout, - HRearrange' l ls rin rout (HList r'), - r'' ~ HList r') => - HRearrange (l ': ls) r r'' where - hRearrange2 _ r = hRearrange2' (Proxy :: Proxy l) (Proxy :: Proxy ls) rin rout + HRearrange4 l ls rin rout r', + l ~ Label ll) => + HRearrange3 (l ': ls) r r' where + hRearrange3 _ r = hRearrange4 (Proxy :: Proxy l) (Proxy :: Proxy ls) rin rout where (rin, rout) = h2projectByLabels (Proxy :: Proxy '[l]) r -- | Helper class 2 for 'hRearrange' -class HRearrange' l ls rin rout r' where - hRearrange2' :: Proxy l -> Proxy ls -> HList rin -> HList rout -> r' - -instance (HRearrange ls rout (HList r'), - r'' ~ HList (Tagged l v ': r')) => - HRearrange' l ls '[Tagged l v] rout r'' where - hRearrange2' _ ls (HCons lv@(Tagged v) _HNil) rout - = HCons (Tagged v `asTypeOf` lv) (hRearrange2 ls rout) +class HRearrange4 (l :: *) (ls :: [*]) rin rout r' | l ls rin rout -> r' where + hRearrange4 :: proxy l -> Proxy ls -> HList rin -> HList rout -> HList r' -data ExtraField l = ExtraField -data FieldNotFound l = FieldNotFound +instance (HRearrange3 ls rout r', + r'' ~ (Tagged l v ': r'), + ll ~ Label l) => + HRearrange4 ll ls '[Tagged l v] rout r'' where + hRearrange4 _ ls (HCons lv@(Tagged v) _HNil) rout + = HCons (Tagged v `asTypeOf` lv) (hRearrange3 ls rout) --- | For improved error messages -instance Fail (FieldNotFound l) => - HRearrange' l ls '[] rout (FieldNotFound l) where - hRearrange2' _ _ _ _ = FieldNotFound +-- | For improved error messages. XXX FieldNotFound +instance Fail (FieldNotFound l ()) => + HRearrange4 l ls '[] rout '[] where + hRearrange4 _ _ _ _ = error "Fail has no instances" -- | For improved error messages -instance Fail (ExtraField l) => - HRearrange '[] (Tagged l v ': a) (ExtraField l) where - hRearrange2 _ _ = ExtraField +instance Fail (ExtraField l) => + HRearrange3 '[] (Tagged l v ': a) '[] where + hRearrange3 _ _ = error "Fail has no instances" -- -------------------------------------------------------------------------- -- $lens --- Lens-based setters/getters are popular. +-- Lens-based setters/getters are popular. hLens packages up +-- 'hUpdateAtLabel' and 'hLookupByLabel'. -- --- This is a provisional method to make a @Lens (Record s) (Record t) a b@, --- out of a 'Label' @x@. Refer to @examples/lens.hs@ for an example. -hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab)) +-- Refer to @examples/lens.hs@ and @examples/labelable.hs@ for examples. +-- | constraints needed to implement 'HLens' +type HLensCxt x r s t a b = + (HasField x (r s) a, + HUpdateAtLabel r x b s t, + HasField x (r t) b, + HUpdateAtLabel r x a t s, + SameLength s t, + SameLabels s t) + +class HLensCxt x r s t a b => HLens x r s t a b + | x s b -> t, x t a -> s, -- need to repeat fundeps implied by HLensCxt + x s -> a, x t -> b where + -- | @hLens :: Label x -> Lens (r s) (r t) a b@ + hLens :: Label x -> (forall f. Functor f => (a -> f b) -> (r s -> f (r t))) + +instance HLensCxt r x s t a b => HLens r x s t a b where + hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab)) + + +{- | map over the values of a record. This is a shortcut for + + > \ f (Record a) -> Record (hMap (HFmap f) a) + +[@Example@] + +suppose we have a function that should be applied to every element +of a record: + +>>> let circSucc_ x | x == maxBound = minBound | otherwise = succ x + +>>> :t circSucc_ +circSucc_ :: (Bounded a, Enum a, Eq a) => a -> a + +Use a shortcut ('Fun') to create a value that has an appropriate 'ApplyAB' instance: + +>>> let circSucc = Fun circSucc_ :: Fun '[Eq,Enum,Bounded] '() + +Confirm that we got Fun right: + +>>> :t applyAB circSucc +applyAB circSucc :: (Bounded b, Enum b, Eq b) => b -> b + +>>> applyAB circSucc True +False + +define the actual record: + +>>> let r = x .=. 'a' .*. y .=. False .*. emptyRecord +>>> r +Record{x='a',y=False} + +>>> hMapR circSucc r +Record{x='b',y=True} + +-} +hMapR f r = applyAB (HMapR f) r + +newtype HMapR f = HMapR f + +instance (HMapCxt Record f x y, rx ~ Record x, ry ~ Record y) + => ApplyAB (HMapR f) rx ry where + applyAB (HMapR f) = hMapAux f + +instance HMapAux HList (HFmap f) x y => + HMapAux Record f x y where + hMapAux f (Record x) = Record (hMapAux (HFmap f) x) + + + +-- -------------------------------------------------------------------------- +-- | This instance allows creating a Record with +-- +-- @hBuild 3 'a' :: Record '[Tagged "x" Int, Tagged "y" Char]@ +instance (HReverse l lRev, + HMapTaggedFn lRev l') => HBuild' l (Record l') where + hBuild' l = hMapTaggedFn (hReverse l) + +-- | serves the same purpose as 'hEnd' +hEndR :: Record a -> Record a +hEndR = id + + +-- | see 'hEndP' +instance (HRevAppR l '[] ~ lRev, + HExtendRs lRev (Proxy ('[] :: [*])) ~ Proxy l1, + l' ~ l1) => HBuild' l (Proxy l') where + hBuild' _ = Proxy + +{- | @'hEndP' $ 'hBuild' label1 label2@ + +is one way to make a Proxy of labels (for use with 'asLabelsOf' +for example). Another way is + +@label1 .*. label2 .*. 'emptyProxy'@ + +-} +hEndP :: Proxy (xs :: [k]) -> Proxy xs +hEndP = id + +type family HExtendRs (ls :: [*]) (z :: k) :: k +type instance HExtendRs (l ': ls) z = HExtendR l (HExtendRs ls z) +type instance HExtendRs '[] z = z + +-- -------------------------------------------------------------------------- + +{- | + +>>> let x :: Record '[Tagged "x" Int]; x = undefined +>>> let y :: Record '[Tagged "x" Char]; y = undefined +>>> :t hZip x y +hZip x y :: Record '[Tagged "x" (Int, Char)] + +-} +instance (HZipRecord x y xy, SameLengths [x,y,xy]) + => HZip Record x y xy where + hZip = hZipRecord + +instance (HZipRecord x y xy, SameLengths [x,y,xy]) + => HUnzip Record x y xy where + hUnzip = hUnzipRecord + + +#if __GLASGOW_HASKELL__ != 706 +{- | Missing from ghc-7.6, because HZip Proxy instances interfere with HZip +HList instances. + +a variation on 'hZip' for 'Proxy', where +the list of labels does not have to include Label +(as in @ts'@) + +>>> let ts = Proxy :: Proxy ["x","y"] +>>> let ts' = Proxy :: Proxy [Label "x",Label "y"] +>>> let vs = Proxy :: Proxy [Int,Char] + +>>> :t zipTagged ts Proxy +zipTagged ts Proxy :: Proxy '[Tagged "x" y, Tagged "y" y1] + +>>> :t zipTagged ts vs +zipTagged ts vs :: Proxy '[Tagged "x" Int, Tagged "y" Char] + + +And and the case when hZip does the same thing: + +>>> :t zipTagged ts' vs +zipTagged ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char] + +>>> :t hZip ts' vs +hZip ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char] + +-} +zipTagged :: (MapLabel ts ~ lts, + HZip Proxy lts vs tvs) + => Proxy ts -> proxy vs -> Proxy tvs +zipTagged _ _ = Proxy +#endif + + + +class HZipRecord x y xy | x y -> xy, xy -> x y where + hZipRecord :: Record x -> Record y -> Record xy + hUnzipRecord :: Record xy -> (Record x,Record y) + + +instance HZipRecord '[] '[] '[] where + hZipRecord _ _ = emptyRecord + hUnzipRecord _ = (emptyRecord, emptyRecord) + +instance HZipRecord as bs abss + => HZipRecord (Tagged x a ': as) (Tagged x b ': bs) (Tagged x (a,b) ': abss) where + hZipRecord (Record (Tagged a `HCons` as)) (Record (Tagged b `HCons` bs)) = + let Record abss = hZipRecord (Record as) (Record bs) + in Record (Tagged (a,b) `HCons` abss) + hUnzipRecord (Record (Tagged (a,b) `HCons` abss)) = + let (Record as, Record bs) = hUnzipRecord (Record abss) + in (Record (Tagged a `HCons` as), Record (Tagged b `HCons` bs)) + + +-- | instead of explicit recursion above, we could define HZipRecord in +-- terms of 'HZipList'. While all types are inferred, this implementation +-- is probably slower, so explicit recursion is used in the 'HZip' 'Record' +-- instance. +hZipRecord2 x y = hMapTaggedFn (hZipList (recordValues x) (recordValues y)) + `asLabelsOf` x `asLabelsOf` y + +hUnzipRecord2 xy = let (x,y) = hUnzipList (recordValues xy) + in (hMapTaggedFn x `asLabelsOf` xy, hMapTaggedFn y `asLabelsOf` xy) + + +{- | similar to 'asTypeOf': + +>>> let s0 = Proxy :: Proxy '["x", "y"] +>>> let s1 = Proxy :: Proxy '[Label "x", Label "y"] +>>> let s2 = Proxy :: Proxy '[Tagged "x" Int, Tagged "y" Char] + +>>> let f0 r = () where _ = r `asLabelsOf` s0 +>>> let f1 r = () where _ = r `asLabelsOf` s1 +>>> let f2 r = () where _ = r `asLabelsOf` s2 + +>>> :t f0 +f0 :: r '[Tagged "x" v, Tagged "y" v1] -> () + +>>> :t f1 +f1 :: r '[Tagged "x" v, Tagged "y" v1] -> () + +>>> :t f2 +f2 :: r '[Tagged "x" v, Tagged "y" v1] -> () + +-} +asLabelsOf :: (HAllTaggedLV x, SameLabels x y, SameLength x y) => r x -> s y -> r x +asLabelsOf = const diff --git a/Data/HList/RecordPuns.hs b/Data/HList/RecordPuns.hs --- a/Data/HList/RecordPuns.hs +++ b/Data/HList/RecordPuns.hs @@ -36,16 +36,18 @@ [@nesting@] -Nesting is supported. The idea is that variables inside -@{ }@ are in another record. More concretely: +Nesting is supported. Variables inside +@{ }@ and @( )@ are one level deeper, like the built-in syntax. +Furthermore the outer @{ }@ can be left out because @[pun|{x}|]@ is more +cluttered than @[pun|x|]@. +More concretely the pattern: -> [pun| ab@{ a b } y z c{d} |] -as a pattern, it will bindings from an original record @x@, -if you interpret (.) as a left-associative field lookup (as it -is in other languages): +> let [pun| ab@{ a b } y z c{d} |] = x -> let ab = xab +is short for: + +> let ab = x.ab > a = x.ab.a > b = x.ab.b > y = x.y @@ -53,49 +55,80 @@ > -- c is not bound > d = x.c.d -as an expression, it creates a new record which needs the variables -@ab a b y z d@ in-scope. @ab@ needs to be a record, and if it has -fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ -which are in scope. +Where here `.` is a left-associative field lookup (as it is in other languages). -@( )@ parens mean the same thing as @{ }@, except the pattern match -restricts the fields in the record supplied to be exactly the ones -provided. In other words +The pun quasiquoter can also be used in an expression context: -> [pun| (x y) |] = list +> let mkX ab a b y z d = [pun| ab@{ a b } y z c{d} |] +> x = mkX ab b y z d + +Here `mkX` includes @ab a b y z d@. @ab@ needs to be a record, and if it has +fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ (via +'hLeftUnion' = '.<++.') . In other words, + +> let mkX ab_ a b y z d = let ab = [pun| a b |] .<++. ab_ +> in [pun| ab y z c{d} |] + +For patterns, any order and additional fields are allowed if @{ }@ is used, +just as in built-in record syntax. But it is often necessary to restrict the +order and number of fields, such as if the record is a 'hRearrange' of a 'hLeftUnion'. +So use @( )@ instead: + +> let [pun| (x _ y{}) |] = list > -- desugars to something like: -> Record (HCons (Tagged x :: Tagged "x" s1) -> (HCons (Tagged x :: Tagged "y" s2) -> HNil)) = list +> Record ((Tagged x :: Tagged "x" s1) `HCons` +> (Tagged _ :: Tagged t s2) `HCons` +> (Tagged _ :: Tagged "y" s3) `HCons` +> HNil) = list -Where the @s1@ and @s2@ are allowed to fit whatever is in the HList. +Note that this also introduces the familiar wild card pattern (@_@), +and shows again how to ensure a label is present but not bind a variable +to it. -See also @examples/pun.hs@. +For comparison, here are three equivalent ways to define variables `x` and `y` + +> let [pun| x y{} |] = r +> let [pun|{ x y{} }|] = r -- or this +> let x = r .!. (Label :: Label "x") +> y = constrainType (r .!. (Label :: Label "y")) +> constrainType :: Record t -> Record t +> constrainType = id + +See also @examples/pun.hs@. In @{}@ patterns, @pun@ can work with +'Variant' too. + -} --- | requires the use of "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@) +-- | requires labels to be promoted strings (kind Symbol), as provided by +-- "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@), +-- or "Data.HList.Labelable" pun :: QuasiQuoter pun = QuasiQuoter { - quotePat = mp . parseRec, - quoteExp = me . parseRec, + quotePat = suppressWarning mp . parseRec, + quoteExp = suppressWarning me . parseRec, quoteDec = error "Data.HList.RecordPuns.quoteDec", quoteType = error "Data.HList.RecordPuns.quoteType" } --- like \x -> (x .!. x1, x .!. x2) +-- | the warning about @implicit {} added@ doesn't +-- make sense at top level (but it does if you say +-- have [pun| x @ y |] +suppressWarning f (V a) = f (C [V a]) +suppressWarning f x = f x + +-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2), +-- where x1 = Label :: Label "x1" extracts xs = do record <- newName "record" - lamE [varP record] - (tupE + -- to fix #5 I could comment out the ensureLength below + lamE [varP record] $ tupE [ [| $(varE record) .!. $label |] | x <- xs, - let label = [| Label :: Label $(litT (strTyLit x)) |] - ]) - -mkExp :: [String] -> ExpQ -mkExp xs = foldr (\x acc -> [| $(mkPair x (dyn x)) .*. $acc |]) [| emptyRecord |] xs + let label = [| Label :: Label $(litT (strTyLit x)) |], + x /= "_" + ] mkPair :: String -> ExpQ -> ExpQ mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |] @@ -119,21 +152,22 @@ show (map ppTree inp) mp :: Tree -> PatQ -mp (C as) = case unzip (mps as) of - (a, b) -> viewP (extracts a) (tupP b) +mp (C as) = + let extractPats = mps as + tupleP = tupP [ p | (binding, p) <- extractPats, binding /= "_" ] + in viewP (extracts (map fst extractPats)) tupleP --- use of prime here (non GADT version) because it is better for type --- inference. See commentary surrounding HCons' in Data.HList.HList + mp (D as) = conP 'Record - [viewP (varE 'prime) -- nicer to have [p| prime -> $( ... ) |], - -- but ghc-7.6 rejects that over types - (foldr ( \ (n,p) xs -> conP 'HCons' - [viewP [| \x -> x `asTypeOf` - (undefined :: Tagged $(litT (strTyLit n)) t) |] - (conP 'Tagged [p]), + [foldr ( \ (n,p) xs -> conP 'HCons + [ let ty + | n == "_" = [| undefined :: Tagged anyLabel t |] + | otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |] + in viewP [| \x -> x `asTypeOf` $ty |] + (conP 'Tagged [p]), xs]) - (conP 'HNil' []) - (mps as))] + (conP 'HNil []) + (mps as)] mp a = do reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a mp (C [a]) @@ -142,6 +176,7 @@ mps (V a : V "@" : b : c) = (a, asP (mkName a) (mp b)) : mps c mps (V a : C b : c) = (a, mp (C b)) : mps c mps (V a : D b : c) = (a, mp (D b)) : mps c +mps (V "_" : b) = ("_", wildP) : mps b mps (V a : b) = (a, varP (mkName a)) : mps b mps [] = [] mps inp = error $ "Data.HList.RecordPuns.mps: cannot translate remaining pattern:" ++ diff --git a/Data/HList/RecordU.hs b/Data/HList/RecordU.hs new file mode 100644 --- /dev/null +++ b/Data/HList/RecordU.hs @@ -0,0 +1,434 @@ +{- | Description: records where elements are stored in unboxed arrays + +The public interface is exported from + +-} +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@ + , 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 +-} diff --git a/Data/HList/TIC.hs b/Data/HList/TIC.hs --- a/Data/HList/TIC.hs +++ b/Data/HList/TIC.hs @@ -1,60 +1,203 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} {- | The HList library (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke - Type-indexed co-products. + Type-indexed co-products. The public interface is exposed + in (There are other ways: see ConsUnion.hs, for example) -} module Data.HList.TIC where -import Data.Dynamic +import Data.HList.TIP +import Data.HList.FakePrelude +import Data.HList.HListPrelude +import Data.HList.Record +import Data.HList.Variant import Data.HList.HList -import Data.HList.TIP +import Data.HList.HArray +import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif +import Text.ParserCombinators.ReadP +import LensDefs + -- -------------------------------------------------------------------------- --- | A datatype for type-indexed co-products +-- | A datatype for type-indexed co-products. A 'TIC' is just a 'Variant', +-- where the elements of the type-level list @\"l\"@ are in the form +-- @Tagged x x@. -newtype TIC (l :: [*]) = TIC Dynamic +newtype TIC (l :: [*]) = TIC (Variant l) +deriving instance Eq (Variant l) => Eq (TIC l) +deriving instance Ord (Variant l) => Ord (TIC l) +deriving instance Ix (Variant l) => Ix (TIC l) +deriving instance Bounded (Variant l) => Bounded (TIC l) +deriving instance Enum (Variant l) => Enum (TIC l) +deriving instance Monoid (Variant l) => Monoid (TIC l) +deriving instance Semigroup (Variant l) => Semigroup (TIC l) + +instance HMapAux Variant f xs ys => HMapAux TIC f xs ys where + hMapAux f (TIC a) = TIC (hMapAux f a) + +-- | @Iso (TIC s) (TIC t) (Variant s) (Variant t)@ +-- +-- 'typeIndexed' may be more appropriate +ticVariant x = isoNewtype (\(TIC a) -> a) TIC x + +-- | @Iso' (TIC s) (Variant s)@ +ticVariant' x = isSimple ticVariant x + + -- -------------------------------------------------------------------------- + +{- | Conversion between type indexed collections ('TIC' and 'TIP') +and the corresponding collection that has other label types ('Variant' +and 'Record' respectively) + +See 'typeIndexed'' + +-} +class TypeIndexed r tr | r -> tr, tr -> r where + -- | @Iso (r s) (r t) (tr a) (tr b)@ + typeIndexed :: forall p f s t a b. + (TypeIndexedCxt s t a b, Profunctor p, Functor f) => + p (tr (TagR a)) (f (tr (TagR b))) -> p (r s) (f (r t)) + +type TypeIndexedCxt s t a b = + (HMapCxt HList TaggedFn b t, + RecordValues s, RecordValues t, + a ~ RecordValuesR s, + b ~ RecordValuesR t, + SameLabels s t, + SameLength s t, + SameLength b a, + {- to use castVariant instead of unsafeCastVariant + RecordValuesR (TagR a) ~ a, + RecordValuesR (TagR b) ~ b, + SameLength (TagR a) s, + SameLength (TagR b) t, + -} + Coercible (TagR b) t, + Coercible (TagR a) s, + HAllTaggedLV s, + HRLabelSet t, + TagUntag a, + TagUntag b) + +instance TypeIndexed Record TIP where + typeIndexed = sameLength . unlabeled . fromTipHList + where fromTipHList = iso (TIP . hTagSelf) (\(TIP a) -> hUntagSelf a) + +instance TypeIndexed Variant TIC where + typeIndexed = isoNewtype unsafeCastVariant unsafeCastVariant + . isoNewtype TIC (\(TIC a) -> a) + +{- | + +@'Iso'' ('Variant' s) ('TIC' a)@ + +@'Iso'' ('Record' s) ('TIP' a)@ + +where @s@ has a type like @'[Tagged \"x\" Int]@, and +@a@ has a type like @'[Tagged Int Int]@. +-} +typeIndexed' x = isSimple typeIndexed x + +-- -------------------------------------------------------------------------- -- | Public constructor (or, open union's injection function) -mkTIC :: ( HTypeIndexed l - , HMember i l True - , Typeable i +mkTIC' :: forall i l proxy. + ( HTypeIndexed l + , MkVariant i i l ) - => i -> TIC l + => i + -> proxy l -- ^ the ordering of types in the @l :: [*]@ matters. + -- This argument is intended to fix the ordering + -- it can be a Record, Variant, TIP, Proxy + -> TIC l -mkTIC i = TIC (toDyn i) +mkTIC' i p = TIC (mkVariant (Label :: Label i) i p) +-- | make a TIC that contains one element +mkTIC1 :: forall i. MkVariant i i '[Tagged i i] => i -> TIC '[Tagged i i] +mkTIC1 i = TIC (mkVariant1 (Label :: Label i) i) +-- | make a TIC for use in contexts where the result type is fixed +mkTIC i = mkTIC' i Proxy + + -- -------------------------------------------------------------------------- -- | Public destructor (or, open union's projection function) +instance HasField o (Variant l) (Maybe o) => + HasField o (TIC l) (Maybe o) where + hLookupByLabel l (TIC i) = hLookupByLabel l i -unTIC :: ( HTypeIndexed l - , HMember o l True - , Typeable o - ) - => TIC l -> Maybe o -unTIC (TIC i) = fromDynamic i +instance (HasField o (TIC l) mo, mo ~ Maybe o) => HOccurs mo (TIC l) where + hOccurs = hLookupByLabel (Label :: Label o) +-- | similar to 'HPrism' +class TICPrism s t a b | s a b -> t, t a b -> s where + ticPrism :: (SameLength s t, Choice p, Applicative f) + => (a `p` f b) -> (TIC s `p` f (TIC t)) + +instance ( + MkVariant b b t, + HasField a (Variant s) (Maybe a), + SameLength s t, + + HFindLabel b t n, + HFindLabel a s n, + + HUpdateAtHNatR n (Tagged b b) s ~ t, + HUpdateAtHNatR n (Tagged a a) t ~ s + + ) => TICPrism s t a b where + ticPrism = ticVariant . prism (\b -> mkVariant (Label :: Label b) b Proxy) + (\s -> case hLookupByLabel (Label :: Label a) s of + Just a -> Right a + Nothing -> Left (unsafeCastVariant s :: Variant t)) + +-- | @Prism' (TIC s) a@ +ticPrism' :: forall s t a b. (HPrism a s t a b, a~b, s~t) + => (forall f p. (Applicative f, Choice p) => (a `p` f b) -> (TIC s `p` f (TIC t))) +ticPrism' = ticVariant . hPrism (Label :: Label a) + + -- -------------------------------------------------------------------------- --- | TICs are opaque +-- | TICs are not opaque -instance Show (TIC l) +instance ShowVariant l => Show (TIC l) where - show _ = "" + 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) diff --git a/Data/HList/TIP.hs b/Data/HList/TIP.hs --- a/Data/HList/TIP.hs +++ b/Data/HList/TIP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- | The HList library @@ -5,26 +6,54 @@ (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke Type-indexed products. + The public interface is described in + -} -module Data.HList.TIP where +module Data.HList.TIP + (module Data.HList.TIPtuple, + module Data.HList.TIP) where import Data.HList.HListPrelude +import Data.HList.FakePrelude import Data.HList.HList -import Data.HList.HArray () -import Data.HList.HTypeIndexed +import Data.HList.Record +import Data.HList.HTypeIndexed () +import Data.HList.TIPtuple +import Data.List (intercalate) +import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif -import Data.HList.TypeEqO () -- for doctest +#if __GLASGOW_HASKELL__ > 710 +import Data.Coerce +#endif +import LensDefs + -- -------------------------------------------------------------------------- -- * The newtype for type-indexed products +-- | TIPs are like 'Record', except element \"i\" of the list \"l\" +-- has type @Tagged e_i e_i@ newtype TIP (l :: [*]) = TIP{unTIP:: HList l} -instance Show (HList l) => Show (TIP l) where - show (TIP l) = "TIP" ++ show l +deriving instance Semigroup (HList a) => Semigroup (TIP a) +deriving instance Monoid (HList a) => Monoid (TIP a) +deriving instance Eq (HList a) => Eq (TIP a) +deriving instance (Ord (HList r)) => Ord (TIP r) +deriving instance (Ix (HList r)) => Ix (TIP r) +deriving instance (Bounded (HList r)) => Bounded (TIP r) + +instance HMapOut (HShow `HComp` HUntag) l String => Show (TIP l) where + showsPrec _ (TIP l) = ("TIPH[" ++) + . (intercalate "," (hMapOut (HShow `HComp` HUntag) l) ++) + . (']' :) + + mkTIP :: HTypeIndexed l => HList l -> TIP l mkTIP = TIP @@ -34,19 +63,29 @@ -- -------------------------------------------------------------------------- -- * Type-indexed type sequences -class HTypeIndexed (l :: [*]) -instance HTypeIndexed '[] -instance (HOccursNot e l,HTypeIndexed l) => HTypeIndexed (e ': l) +-- | this constraint ensures that a TIP created by 'mkTIP' has no +-- duplicates +class (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed (l :: [*]) +instance (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed l + +class HAllTaggedEq (l :: [*]) +instance HAllTaggedEq '[] +instance (HAllTaggedEq l, tee ~ Tagged e e') => HAllTaggedEq (tee ': l) + -- -------------------------------------------------------------------------- -- Implementing the HListPrelude interface -instance (HOccursNot e l, HTypeIndexed l) => HExtend e (TIP l) +instance (HRLabelSet (Tagged e e ': l), HTypeIndexed l) => HExtend e (TIP l) where - type HExtendR e (TIP l) = TIP (e ': l) - e .*. TIP l = mkTIP (HCons e l) + type HExtendR e (TIP l) = TIP (Tagged e e ': l) + e .*. TIP l = mkTIP (HCons (Tagged e) l) + +instance (e ~ e', HasField e (Record l) e') => HasField e (TIP l) e' where + hLookupByLabel lab (TIP l) = hLookupByLabel lab (Record l) + -- | One occurrence and nothing is left -- -- This variation provides an extra feature for singleton lists. @@ -54,43 +93,102 @@ -- Hence the explicit provision of a result type can be omitted. -- -instance e' ~ e => HOccurs e' (TIP '[e]) where - hOccurs (TIP (HCons e' _)) = e' +instance (tee ~ Tagged e e) => HOccurs e (TIP '[tee]) where + hOccurs (TIP (HCons (Tagged e) _)) = e -instance HOccurs e (HList (x ': y ': l)) +instance HasField e (Record (x ': y ': l)) e => HOccurs e (TIP (x ': y ': l)) where - hOccurs (TIP l) = hOccurs l - - -instance HOccursNot e l => HOccursNot e (TIP l) + hOccurs (TIP l) = Record l .!. (Label :: Label e) -instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendList l l')) +instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendListR l l')) => HAppend (TIP l) (TIP l') where hAppend (TIP l) (TIP l') = mkTIP (hAppend l l') -type instance HAppendR (TIP l) (TIP l') = TIP (HAppendList l l') +type instance HAppendR (TIP l) (TIP l') = TIP (HAppendListR l l') --- instance HOccurrence e l l' => HOccurrence e (TIP l) l' + +-- instance HOccurrence HList e l l' => HOccurrence TIP e l l' -- where --- hOccurrence e = hOccurrence e . unTIP +-- hOccurrence e = TIP . hOccurrence e . unTIP -- -------------------------------------------------------------------------- -- * Shielding type-indexed operations -- $note The absence of signatures is deliberate! They all must be inferred. -onTIP f (TIP l) = mkTIP (f l) +onRecord f (TIP l) = let Record l' = f (Record l) in mkTIP l' -tipyDelete p t = onTIP (hDeleteAt p) t -tipyUpdate e t = onTIP (hUpdateAt e) t -tipyProject ps t = onTIP (hProjectBy ps) t +instance (HDeleteAtLabel Record e v v', + HTypeIndexed v') + => HDeleteAtLabel TIP e v v' where + hDeleteAtLabel e v = onRecord (hDeleteAtLabel e) v --- | Split produces two TIPs -tipySplit ps (TIP l) = (mkTIP l',mkTIP l'') +tipyUpdate e t = hTPupdateAtLabel (fromValue e) e t + where fromValue :: e -> Label e + fromValue _ = Label + +instance (HUpdateAtLabel Record e' e r r', + HTypeIndexed r', + e ~ e') => HUpdateAtLabel TIP e' e r r' where + hUpdateAtLabel l e r = onRecord (hUpdateAtLabel l e) r + + +-- | Use 'Labels' to specify the first argument +tipyProject ps t = onRecord (hProjectByLabels ps) t + +-- | provides a @Lens' (TIP s) a@. 'hLens'' @:: Label a -> Lens' (TIP s) a@ +-- is another option. +#if __GLASGOW_HASKELL__ < 707 +tipyLens' x = isSimple tipyLens x -- rejected by GHC-7.10RC1 +#else +tipyLens' f s = isSimple (hLens x) f (asTIP s) -- rejected by GHC-7.6.3 + where + x = getA f + getA :: (a -> f a) -> Label a + getA _ = Label + + asTIP :: TIP a -> TIP a + asTIP = id +#endif + +{- | provides a @Lens (TIP s) (TIP t) a b@ + +When using @set@ (also known as @.~@), 'tipyLens'' can address the +ambiguity as to which field \"a\" should actually be updated. + +-} +tipyLens f (TIP s) = + case hSplitAt (getN s f) (ghc8fix1 s) of + (x, ta@(Tagged a) `HCons` ys) + | () <- ghc8fix2 ta -> + let mkt b = mkTIP (x `hAppendList` (tagSelf b `HCons` ys)) + in mkt <$> f a + where + getN :: HFind (Label a) (LabelsOf s) n => HList s -> (a -> f b) -> Proxy n + getN _ _ = Proxy + + -- without these, tipyLens has a type that has kind variables, + -- (that end up being * when an actual TIP is provided), leading to + -- a Properties.LengthIndependent compile error: + -- .../.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/Data/HList/TIP.hi + -- Declaration for tipyLens: + -- Iface type variable out of scope: k + -- Cannot continue after interface file error + ghc8fix1 :: HList (Tagged x x ': xs) -> HList (Tagged x x ': xs) + ghc8fix1 = id + + ghc8fix2 :: Tagged a a -> () + ghc8fix2 _ = () + + + +-- | The same as 'tipyProject', except also return the +-- types not requested in the @proxy@ argument +tipyProject2 ps (TIP l) = (mkTIP l',mkTIP l'') where - (l',l'') = hSplitBy ps l + (l',l'') = h2projectByLabels ps l -- -------------------------------------------------------------------------- @@ -103,14 +201,300 @@ -- -------------------------------------------------------------------------- +-- * conversion to and from 'HList' +{- | 'TagR' can also be used to avoid redundancy when defining types for TIC and TIP. + +> type XShort = TagR [A,B,C,D] + +> type XLong = [Tagged A A, Tagged B B, Tagged C C, Tagged D D] + + +an equivalent FD version, which is slightly better with respect to +simplifying types containing type variables (in ghc-7.8 and 7.6): + + +With ghc-7.10 () 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. + +The problem is an interesting variation of the keyword argument problem. + +Examples can be found in @examples/TIPTransform.hs@ and @examples/TIPTransformM.hs@ +-} + +class TransTIP op db where + ttip :: op -> TIP db -> TIP db + +instance (HMember (Tagged op op) db b, + Arity op n, + TransTIP1 b n op db) + => TransTIP op db where + ttip = ttip1 (Proxy ::Proxy b) (Proxy :: Proxy n) + +class TransTIP1 (b :: Bool) (n :: HNat) op db where + ttip1 :: Proxy b -> Proxy n -> op -> TIP db -> TIP db + +-- If op is found in a TIP, update the TIP with op +instance HTPupdateAtLabel TIP op op db + => TransTIP1 True n op db where + ttip1 _ _ = tipyUpdate + +-- If op is not found in a TIP, it must be a function. Try to look up +-- its argument in a TIP and recur. +instance (HMember (Tagged arg arg) db b, + TransTIP2 b arg op db) + => TransTIP1 False (HSucc n) (arg -> op) db where + ttip1 _ _ = ttip2 (Proxy :: Proxy b) + +instance Fail (FieldNotFound notfun (TIP db)) + => TransTIP1 False HZero notfun db where + ttip1 = error "TransTIP1 Fail failed" + +class TransTIP2 (b :: Bool) arg op db where + ttip2 :: Proxy b -> (arg -> op) -> TIP db -> TIP db + +instance (HOccurs arg (TIP db), + TransTIP op db) + => TransTIP2 True arg op db where + ttip2 _ f db = ttip (f (hOccurs db)) db + +instance Fail (FieldNotFound arg (TIP db)) + => TransTIP2 False arg op db where + ttip2 = error "TransTIP2 Fail failed" + +-- ** Monadic version + +{- | + +In March 2010, Andrew Frank extended the problem for monadic operations. +This is the monadic version of @TIPTransform.hs@ in the present directory. + +This is the TF implementation. When specifying the operation to perform over +a TIP, we can leave it polymorphic over the monad. The type checker +will instantiate the monad based on the context. + +-} +class Monad m => TransTIPM m op db where + ttipM :: op -> TIP db -> m (TIP db) + +-- Check to see if the operation is a computation whose result +-- is in the TIP. The type variable m' of the kind *->* below +-- can be instantiated either to a monad type constructor, or (arg->). +instance (Monad m, HMember (Tagged op op) db b, + Arity (m' op) n, + TransTIPM1 b n m (m' op) db) + => TransTIPM m (m' op) db where + ttipM = ttipM1 (Proxy :: Proxy b) (Proxy :: Proxy n) + +class Monad m => TransTIPM1 (b :: Bool) (n :: HNat) m op db where + ttipM1 :: Proxy b -> Proxy n -> op -> TIP db -> m (TIP db) + +-- If op is found in a TIP, update the TIP with op. +-- The type variable m' must be equal to the type of the monad +-- in which the final result is reported. +instance (Monad m, m ~ m', HTPupdateAtLabel TIP op op db) + => TransTIPM1 True n m (m' op) db where + ttipM1 _ _ op db = do + op' <- op + return $ tipyUpdate op' db + +instance (Fail (FieldNotFound op (TIP db)), Monad m) + => TransTIPM1 False HZero m op db where + ttipM1 _ _ = error "TransTIPM1 Fail failed" + +-- If op is not found in a TIP, it must be a function. Look up +-- its argument in a TIP and recur. +instance (Monad m, + HMember (Tagged arg arg) db b, + TransTIPM2 b m arg op db) + => TransTIPM1 False (HSucc n) m (arg-> op) db where + ttipM1 _ _ = ttipM2 (Proxy :: Proxy b) + + +class TransTIPM2 (b :: Bool) m arg op db where + ttipM2 :: Proxy b -> (arg -> op) -> TIP db -> m (TIP db) + +instance (HOccurs arg (TIP db), TransTIPM m op db) + => TransTIPM2 True m arg op db where + ttipM2 _ f db = ttipM (f (hOccurs db)) db + + +instance Fail (FieldNotFound op (TIP db)) + => TransTIPM2 False m arg op db where + ttipM2 _ _ = error "TransTIPM1 Fail failed" + +-- -------------------------------------------------------------------------- + +-- tests for tipyTuple. These only work if tipyTuple is compiled +-- in a module that has NoMonoLocalBinds enabled +_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Char, Bool) +_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Bool, Char) + + +-- -------------------------------------------------------------------------- + -- * Sample code {- $setup [@Assume@] +>>> import Data.HList.TypeEqO >>> import Data.HList.FakePrelude +>>> import Data.HList.HOccurs >>> :{ newtype Key = Key Integer deriving (Show,Eq,Ord) @@ -118,13 +502,12 @@ data Breed = Cow | Sheep deriving (Show,Eq) newtype Price = Price Float deriving (Show,Eq,Ord) data Disease = BSE | FM deriving (Show,Eq) -type Animal = '[Key,Name,Breed,Price] +type Animal = TagR '[Key,Name,Breed,Price] :} >>> :{ -let myAnimal :: HList Animal - myAnimal = hBuild (Key 42) (Name "Angus") Cow (Price 75.5) - myTipyCow = TIP myAnimal +let myTipyCow :: TIP Animal -- optional + myTipyCow = Key 42 .*. Name "Angus" .*. Cow .*. Price 75.5 .*. emptyTIP animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key animalKey = hOccurs :} @@ -135,22 +518,32 @@ [@Session log@] >>> :t myTipyCow -myTipyCow :: TIP Animal +myTipyCow + :: TIP + '[Tagged Key Key, Tagged Name Name, Tagged Breed Breed, + Tagged Price Price] >>> hOccurs myTipyCow :: Breed Cow >>> BSE .*. myTipyCow -TIPH[BSE, Key 42, Name "Angus", Cow, Price 75.5] +TIPH[BSE,Key 42,Name "Angus",Cow,Price 75.5] ->>> Sheep .*. tipyDelete (Proxy::Proxy Breed) myTipyCow -TIPH[Sheep, Key 42, Name "Angus", Price 75.5] +>>> Sheep .*. hDeleteAtLabel (Label::Label Breed) myTipyCow +TIPH[Sheep,Key 42,Name "Angus",Price 75.5] >>> tipyUpdate Sheep myTipyCow -TIPH[Key 42, Name "Angus", Sheep, Price 75.5] +TIPH[Key 42,Name "Angus",Sheep,Price 75.5] + +>>> tipyProject2 (Proxy :: Labels '[Name,Price]) myTipyCow +(TIPH[Name "Angus",Price 75.5],TIPH[Key 42,Cow]) + +>>> tipyProject (Proxy :: Labels '[Name,Price]) myTipyCow +TIPH[Name "Angus",Price 75.5] + -} @@ -158,9 +551,10 @@ Don't bother repeating the type error: ->>> let doctestEq x y = x == y || "No instance for" `Data.List.isInfixOf` x >>> Sheep .*. myTipyCow --- type error -- +... +...No instance for (Fail (DuplicatedLabel (Label Breed))) +... -} diff --git a/Data/HList/TIPtuple.hs b/Data/HList/TIPtuple.hs new file mode 100644 --- /dev/null +++ b/Data/HList/TIPtuple.hs @@ -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 diff --git a/Data/HList/TypeEqO.hs b/Data/HList/TypeEqO.hs --- a/Data/HList/TypeEqO.hs +++ b/Data/HList/TypeEqO.hs @@ -1,13 +1,18 @@ +{-# LANGUAGE CPP #-} +#if (__GLASGOW_HASKELL__ < 709) {-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif {- | The HList library (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke - Generic type equality predicate: + Generic type equality predicate: The implementation based on overlapping instances The only place where overlapping instances are really used + besides Label5 -} @@ -15,15 +20,36 @@ import Data.HList.FakePrelude -instance HEq x x True -instance False ~ b => HEq x y b +#if !NEW_TYPE_EQ +instance {-# OVERLAPPING #-} HEq x x True +instance {-# OVERLAPPABLE #-} False ~ b => HEq x y b -- instance TypeEq x y HFalse -- would violate functional dependency +#endif -class TupleType t (b :: Bool) | t -> b -instance TupleType () True -instance TupleType (x,y) True -instance TupleType (x,y,z) True + +class TupleType (t :: *) (b :: Bool) | t -> b +instance {-# OVERLAPPING #-} TupleType () True +instance {-# OVERLAPPING #-} TupleType (x,y) True +instance {-# OVERLAPPING #-} TupleType (x,y,z) True -- Continue for a while -instance False ~ b => TupleType x b +instance {-# OVERLAPPABLE #-} False ~ b => TupleType x b -- instance TupleType x HFalse -- would violate functional dependency + +-- overlaps an instance Show (Proxy t) for convenience +instance {-# OVERLAPPING #-} Show (Proxy True) where show _ = "HTrue" +instance {-# OVERLAPPING #-} Show (Proxy False) where show _ = "HFalse" + +instance {-# OVERLAPPING #-} HNat2Integral n => Show (Proxy (n :: HNat)) where + show n = "H" ++ show (hNat2Integral n :: Integer) + + +instance {-# OVERLAPPABLE #-} hZero ~ HZero => ArityFwd f hZero +instance {-# OVERLAPPING #-} Arity f n => ArityFwd (x -> f) (HSucc n) + + +-- | All our keywords must be registered +class IsKeyFN (t :: *) (flag :: Bool) | t-> flag +-- | overlapping/fallback case +instance {-# OVERLAPPABLE #-} (False ~ flag) => IsKeyFN t flag + diff --git a/Data/HList/Variant.hs b/Data/HList/Variant.hs --- a/Data/HList/Variant.hs +++ b/Data/HList/Variant.hs @@ -1,68 +1,1185 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, UndecidableInstances #-} - - -{- | - The HList library - - (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke - - Variants, i.e., labelled sums. - - One approach to their implementation would be to consider both - the favoured label and the corresponding value as dynamics upon - variant construction. Since we are too lazy to programme some - Typeable instances for non-ghc systems (NB: in GHC, Typeable - is derivable), we rather model variants as (opaque) records - with maybies for the values. Only one value will actually hold - non-Nothing, as guaranteed by the constructor. - - See VariantP.hs for a different approach to open sums. --} - -module Data.HList.Variant where - -import Data.HList.FakePrelude -import Data.HList.Record -import Data.HList.HList - - --- -------------------------------------------------------------------------- --- | Variant types on the basis of label-maybe pairs. - -newtype Variant mr = Variant mr - - --- -------------------------------------------------------------------------- --- | Turn proxy sequence into sequence of Nothings - -data HMaybeF = HMaybeF -instance ((Tagged l (Proxy t) ~ a, b ~ Tagged l (Maybe t))) => ApplyAB HMaybeF a b where - applyAB _ _ = Tagged Nothing - -hMaybied x = hMap HMaybeF x - - --- -------------------------------------------------------------------------- --- | Public constructor --- it seems we can blame 'hUpdateAtLabel' (not 'HMap') for needing the asTypeOf? -mkVariant x y (Record v) = let r1 = Record (hMaybied v) in - case hUpdateAtLabel x (Just y) r1 `asTypeOf` r1 of - Record t -> Variant t - --- -------------------------------------------------------------------------- --- | Public destructor - -unVariant x (Variant v) = hLookupByLabel x (Record v) - - --- -------------------------------------------------------------------------- --- | Variants are opaque - -instance Show (Variant v) - where - show _ = "" - - +{-# LANGUAGE CPP #-} + +{- | + Description: Variants, i.e., labelled sums, generalizations of Either + + The HList library + + See + 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 ...@ +* + +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 diff --git a/Data/HList/broken/Label5.hs b/Data/HList/broken/Label5.hs deleted file mode 100644 --- a/Data/HList/broken/Label5.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses #-} - -{- | - The HList library - - (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke - - Yet another model of labels. - - This model allow us to use any type as label type. - As a result, we need some generic instances. - - Also, type errors may be more confusing now. --} - -module Data.HList.Label5 where - -import Data.Typeable -import Data.Char -import Data.HList.FakePrelude -import Data.HList.Record - - --- | Equality on labels - --- instance TypeEq x y b => HEq x y b - - --- | Show label - -instance Typeable x => ShowLabel x - where - showLabel = (\(x:xs) -> toLower x:xs) - . reverse - . takeWhile (not . (==) '.') - . reverse - . show -{- - . tyConString - . typeRepTyCon --} - . typeOf diff --git a/Data/HList/broken/RecordAdv.hs b/Data/HList/broken/RecordAdv.hs --- a/Data/HList/broken/RecordAdv.hs +++ b/Data/HList/broken/RecordAdv.hs @@ -32,8 +32,6 @@ -- -- Replace a proxy by a value of the proxied type. -- The signature is inferred -hUnproxyLabel :: (HFind l (RecordLabels r) n,HUpdateAtHNat n (LVPair l v) r,HasField l (Record r) (Proxy v)) => - Label l-> v -> Record r -> Record (HUpdateAtHNatR n (LVPair l v) r) hUnproxyLabel l v r = hUpdateAtLabel l v r where tpe :: a -> Proxy a -> () @@ -45,8 +43,7 @@ {-| This is a variation on updating, so use the same fixity as (.\@.). -} -f@(LVPair v) .^. r = hUnproxyLabel (labelLVPair f) v r - +f@(Tagged v) .^. r = hUnproxyLabel (labelLVPair f) v r -- -------------------------------------------------------------------------- @@ -61,10 +58,11 @@ class HasNoProxies (l :: [*]) instance HasNoProxies '[] instance Fail (ProxyFound x) => HasNoProxies (Proxy x ': l) -instance Fail (ProxyFound x) => HasNoProxies (LVPair lab (Proxy x) ': l) +instance Fail (ProxyFound x) => HasNoProxies (Tagged lab (Proxy x) ': l) instance HasNoProxies l => HasNoProxies (e ': l) + -- -------------------------------------------------------------------------- -- | Narrow a record to a different record type @@ -75,16 +73,16 @@ class NarrowM a b res | a b -> res where narrowM :: Record a -> Record b -> res -instance NarrowM a '[] (HJust (Record '[])) where +instance res ~ HJust (Record '[]) => NarrowM a '[] res where narrowM _ _ = HJust emptyRecord instance (H2ProjectByLabels (l ': '[]) a rin rout, NarrowM' rin rout b res) - => NarrowM a (LVPair l v ': b) res where + => NarrowM a (Tagged l v ': b) res where narrowM (Record a) _ = narrowM' (Record rin) (Record rout) (undefined:: Record b) where - (rin,rout) = h2projectByLabels (proxy :: Proxy (l ': '[])) a + (rin,rout) = h2projectByLabels (Proxy :: Proxy (l ': '[])) a -- | could be changed to type family class NarrowM' rin rout b res | rin rout b -> res where @@ -99,10 +97,10 @@ narrowM' (Record (f `HCons` HNil)) rout b = narrowM'' f (narrowM rout b) -class NarrowM'' f r r' where +class NarrowM'' f r r' | f r -> r' where narrowM'' :: f -> r -> r' -instance (hNothing ~ HNothing) => NarrowM'' f HNothing hNothing where +instance NarrowM'' f HNothing HNothing where narrowM'' _ _ = HNothing instance NarrowM'' f (HJust (Record r)) (HJust (Record (f ': r))) where @@ -116,10 +114,10 @@ where narrow _ = emptyRecord instance ( Narrow rout r' - , H2ProjectByLabels (l ': '[]) r (LVPair l v ': '[]) rout - ) => Narrow r ( LVPair l v ': r' ) + , H2ProjectByLabels (l ': '[]) r (Tagged l v ': '[]) rout + ) => Narrow r ( Tagged l v ': r' ) where - narrow (Record r) = case h2projectByLabels (proxy::Proxy (l ': '[])) r of + narrow (Record r) = case h2projectByLabels (Proxy::Proxy (l ': '[])) r of (HCons f HNil,rout) -> let (Record r') = narrow (Record rout) in Record (HCons f r') @@ -132,7 +130,7 @@ where lubNarrow :: Record a -> Record b -> (Record c, Record c) -instance ( HTIntersect (RecordLabels a) (RecordLabels b) lc +instance ( HTIntersect (LabelsOf a) (LabelsOf b) lc , H2ProjectByLabels lc a c aout , H2ProjectByLabels lc b c bout , HRLabelSet c @@ -141,16 +139,16 @@ where lubNarrow ra@(Record _) rb@(Record _) = - ( hProjectByLabels (proxy::Proxy lc) ra - , hProjectByLabels (proxy::Proxy lc) rb + ( hProjectByLabels (Proxy::Proxy lc) ra + , hProjectByLabels (Proxy::Proxy lc) rb ) -{- -- -------------------------------------------------------------------------- -- | List constructors that also LUB together +{- data NilLub nilLub :: NilLub nilLub = undefined @@ -176,33 +174,32 @@ class HLub l e | l -> e where - hLub :: l -> [e] + hLub :: HList l -> [e] instance ( LubNarrow h h' e ) - => HLub (HCons h (HCons h' HNil)) e + => HLub [h,h'] e where hLub (HCons h (HCons h' _)) = [fst ee, snd ee] where ee = lubNarrow h h' -instance ( HLub (HCons h (HCons h'' t)) e' - , HLub (HCons h' (HCons h'' t)) e'' +instance ( HLub (h ': h'' ': t) e' + , HLub (h' ': h'' ': t) e'' , LubNarrow e' e'' e - , HLub (HCons e (HCons h'' t)) e + , HLub (e ': h'' ': t) e ) - => HLub (HCons h (HCons h' (HCons h'' t))) e + => HLub (h ': h' ': h'' ': t) e where - hLub (HCons h (HCons h' t)) = fst e : ( snd e : tail r ) + hLub (HCons h (HCons h' t)) = fst e : snd e : tail r where e' = hLub (HCons h t) e'' = hLub (HCons h' t) e = lubNarrow (head e') (head e'') r = hLub (HCons (fst e) t) + -} --} - -- -------------------------------------------------------------------------- -- | Record equivalence modulo field order -- @@ -227,13 +224,13 @@ -- field uniquely determines the type of the field value. Therefore, we -- should not use equivR on two records with inconsistent labeling... -class RecordEquiv r1 r2 res | r1 r2 -> res where +class RecordEquiv r1 r2 res where equivR :: r1 -> r2 -> res instance (HEq r1 r2 b, RecordEquiv' b r1 r2 res) => RecordEquiv r1 r2 res where - equivR _ _ = equivR' (undefined::Proxy b) (undefined::r1) (undefined::r2) + equivR _ _ = equivR' (Proxy::Proxy b) (undefined::r1) (undefined::r2) -- Two records have the same type: the fast path instance RecordEquiv' True r r (HJust (r->r,r->r)) where @@ -242,14 +239,15 @@ instance (NarrowM r1 r2 r12, NarrowM r2 r1 r21, RecordEquiv' False (Record r1->r12) (Record r2->r21) res) => RecordEquiv (Record r1) (Record r2) res where - equivR r1 r2 = equivR' (undefined :: Proxy False) r1p r2p + equivR r1 r2 = equivR' (Proxy :: Proxy False) r1p r2p where r1p r1 = narrowM (r1 :: Record r1) r2 r2p r2 = narrowM (r2 :: Record r2) r1 class RecordEquiv' (b :: Bool) pj1 pj2 res | b pj1 pj2 -> res where equivR' :: Proxy b -> pj1 -> pj2 -> res -instance RecordEquiv' False (r1->HJust r2) (r2->HJust r1) (HJust (r1->r2,r2->r1)) +instance res ~ HJust (r1->r2,r2->r1) => + RecordEquiv' False (r1->HJust r2) (r2->HJust r1) res where equivR' _ r12 r21 = HJust (unj.r12,unj.r21) where unj (HJust x) = x @@ -262,45 +260,9 @@ instance RecordEquiv' False (r1->HJust r2) (r2->HNothing) HNothing where equivR' _ _ _ = HNothing -{- -- -------------------------------------------------------------------------- --- Typeable instances - -hNilTcName :: TyCon -hNilTcName = mkTyCon "HList.HNil" -instance Typeable HNil - where - typeOf _ = mkTyConApp hNilTcName [] - -hConsTcName :: TyCon -hConsTcName = mkTyCon "HList.HCons" -instance (Typeable x, Typeable y) => Typeable (HCons x y) - where - typeOf ~(HCons x y) - = mkTyConApp hConsTcName [ typeOf x, typeOf y ] - -recordTcName :: TyCon -recordTcName = mkTyCon "HList.Record" -instance Typeable x => Typeable (Record x) - where - typeOf ~(Record x) - = mkTyConApp recordTcName [ typeOf x ] - -hFieldTcName :: TyCon -hFieldTcName = mkTyCon "HList.F" -instance (Typeable x, Typeable y) => Typeable (LVPair x y) - where - typeOf _ - = mkTyConApp hFieldTcName [ typeOf (undefined::x), typeOf (undefined::y) ] - -proxyTcName :: TyCon -proxyTcName = mkTyCon "HList.Proxy" -instance Typeable x => Typeable (Proxy x) - where - typeOf _ - = mkTyConApp proxyTcName [ typeOf (undefined::x) ] - +-- * Typeable instances +-- TODO: see Data.HList.Data --} diff --git a/Data/HList/broken/RecordOrd.hs b/Data/HList/broken/RecordOrd.hs new file mode 100644 --- /dev/null +++ b/Data/HList/broken/RecordOrd.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +-- | records with Symbol labels that are sorted. Not enabled yet +-- because CmpSymbol comes with ghc>=7.8 and ghc-7.6 is not dropped yet +module Data.HList.RecordOrd where + +import Data.HList.HList +import Data.HList.HListPrelude +import Data.HList.FakePrelude +import Data.Tagged + +import GHC.TypeLits +import Data.Type.Equality + +import Data.HList.Record + +-- two-class version +class InsertOrd1 kv l l' | kv l -> l' where + insertOrd1 :: kv -> HList l -> HList l' + +class InsertOrd2 (b :: Ordering) kv l l' | b kv l -> l' where + insertOrd2 :: Proxy b -> kv -> HList l -> HList l' + + +instance InsertOrd2 LT kv l (kv ': l) where + insertOrd2 _ kv l = HCons kv l + +instance (x ~ (l1 ': rest), + y ~ (l1 ': rest'), + InsertOrd1 kv rest rest') => InsertOrd2 GT kv x y where + insertOrd2 _ kv (HCons l1 rest) = HCons l1 (insertOrd1 kv rest) + insertOrd2 _ _ _ = error "Data.HList.RecordOrd: ghc bug" + + +instance Fail (DuplicatedLabel kv) => InsertOrd2 EQ kv x '[DuplicatedLabel kv] where + insertOrd2 _ _ _ = error "Data.HList.RecordOrd: there must be no instances of Fail" + + +instance ( b ~ CmpSymbol k k', + taggedkv ~ Tagged k v, + taggedk'v' ~ Tagged k' v', + InsertOrd2 b taggedkv (taggedk'v' ': kvs) kvs') + => InsertOrd1 taggedkv (taggedk'v' ': kvs) kvs' where + insertOrd1 kv kvs = insertOrd2 (Proxy :: Proxy b) kv kvs + +instance InsertOrd1 x '[] '[x] where + insertOrd1 kv _ = HCons kv HNil + +data InsertOrd = InsertOrd +instance (x ~ (e, HList r), + InsertOrd1 e r r', + y ~ HList r' + )=> ApplyAB InsertOrd x y where + applyAB _ (e,r) = insertOrd1 e r + +hSort' xs = hFoldr InsertOrd HNil xs + + +class HSorted (r :: [*]) + +instance HSorted '[] +instance HSorted '[x] +instance (HSorted (ty ': rest), + tx ~ Tagged x vx, + ty ~ Tagged y vy, + CmpSymbol x y ~ LT) + => HSorted (tx ': ty ': rest) + + +{- + +In principle this could be an appropriate proxy to use +for Variant: once the field ordering and number of fields +is fixed, as it would be for + +_left = Label :: Label "left" +_right = Label :: Label "right" + +(v,w) = case sortedProxyLen (hSucc (hSucc hZero)) of + e -> (mkVariant _left 'x' e, + mkVariant _right (5 :: Int) e) + +Then: + +v :: (HasField' b1 "right" '[Tagged x a, Tagged y a1] Int, + HasField' b "left" '[Tagged x a, Tagged y a1] Char, + HFind2 b1 "right" '[y] n1, HFind2 b "left" '[y] n, + HNat2Integral n1, HNat2Integral n, HEq "right" x b1, + HEq "left" x b, GHC.TypeLits.CmpSymbol x y ~ 'LT) => + Variant '[Tagged x a, Tagged y a1] + +Does not reduce to v :: Variant '[Tagged "left" Char, Tagged "right" Int] + +If only ghc would backtrack after trying (x ~ "left") or (y ~ "right") +and see that only one will satisfy @CmpSymbol x y ~ LT@, + + +-} +sortedProxyLen :: (HSorted r, + SameLength' (HReplicateR n ()) r_, + HMapCxt (HFmap (Fun '[] ())) r r_) + => Proxy n -> Proxy r +sortedProxyLen _ = Proxy + +class HSort xs xs' where + hSort :: SameLength xs xs' => Record xs -> Record xs' + +instance HFoldr InsertOrd (HList '[]) xs (HList xs') => HSort xs xs' where + hSort (Record xs) = Record (hSort' xs) + +{- two type family version +type family InsertOrd1 kv kvs where + InsertOrd1 kv '[] = '[kv] + InsertOrd1 (Tagged k v) (Tagged k' v' ': kvs) = + InsertOrd2 + (CmpSymbol k k') + (Tagged k v) + (Tagged k' v' ': kvs) + +type family InsertOrd2 (b :: Ordering) (kv :: *) (kvs :: [*]) where + InsertOrd2 b x '[] = '[x] + InsertOrd2 GT (Tagged k v) (Tagged k' v' ': kvs) = + InsertOrd1 (Tagged k v) (Tagged k' v' ': kvs) + InsertOrd2 LT kv kvs = kv ': kvs + InsertOrd2 EQ kv kvs = Err (DuplicatedLabel kv) '[] + +-- | Error messages: http://www.haskell.org/pipermail/haskell-cafe/2013-November/111549.html +type family Err (x::k) (a :: j) :: j where + Err x a = Err x (Err "infinite loop to bring this to your attention: don't raise the context stack please" a) +-} + + +{- + +-- Narrowing records +class (HRLabelSet a, HRLabelSet b) => Narrow a b where + narrow :: Record a -> Record b + +instance (HRLabelSet a, + HRLabelSet b, + HRLabelSet bOut, + H2ProjectByLabels (RecordLabels b :: [k]) a b bOut) + => Narrow a b where + narrow a = case hProjectByLabels2 (Proxy :: Proxy (RecordLabels b :: [k])) a + of (b :: Record b, _bOut :: Record bOut) -> b + -} diff --git a/Data/HList/broken/RecordP.hs b/Data/HList/broken/RecordP.hs --- a/Data/HList/broken/RecordP.hs +++ b/Data/HList/broken/RecordP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} @@ -33,23 +34,18 @@ -- -------------------------------------------------------------------------- -- Record types as Phantom labels with values -newtype RecordP (ls::[*]) vs = RecordP (HList vs) +newtype RecordP (ls::[k]) vs = RecordP (HList vs) -- Build a record. I wonder if the 'ls' argument of mkRecordP can be -- removed. So far, we had no need for it... -mkRecordP :: (HSameLength ls vs, HLabelSet ls) => ls -> vs -> RecordP ls vs +mkRecordP :: (SameLength ls vs, HLabelSet ls) => proxy ls -> HList vs -> RecordP ls vs mkRecordP _ vs = RecordP vs --- The contraint that two type level lists have the same length -class HSameLength l1 l2 -instance HSameLength '[] '[] -instance HSameLength l1 l2 => HSameLength (e1 ': l1) (e2 ': l2) - -- Build an empty record emptyRecordP :: RecordP ('[]) ('[]) -emptyRecordP = mkRecordP HNil HNil +emptyRecordP = mkRecordP Proxy HNil -- Converting between RecordP and Record (label/value pairs) @@ -62,16 +58,14 @@ record_r2p _ = emptyRecordP record_p2r _ = emptyRecord -{- -instance (RecordR2P r ls vs, HRLabelSet (HCons (LVPair l v) r), - HLabelSet (HCons l ls), HSameLength ls vs) - => RecordR2P (HCons (LVPair l v) r) (HCons l ls) (HCons v vs) where - record_r2p (Record (HCons f r)) = hExtend f (record_r2p (Record r)) - record_p2r (RecordP (HCons v r)) = hExtend (LVPair v) (record_p2r (RecordP r)) - -labels_of_recordp :: RecordP ls vs -> ls -labels_of_recordp = undefined +instance (RecordR2P r ls vs, HRLabelSet (Tagged l v ': r), + HLabelSet (l ': ls), SameLength ls vs) + => RecordR2P (Tagged l v ': r) (l ': ls) (v ': vs) where + record_r2p (Record (HCons f r)) = f .*. record_r2p (Record r) + record_p2r (RecordP (HCons v r)) = Tagged v .*. record_p2r (RecordP r) +labels_of_recordp :: RecordP ls vs -> Proxy ls +labels_of_recordp _ = Proxy -- -------------------------------------------------------------------------- -- A Show instance to appeal to normal records @@ -85,24 +79,29 @@ -- -------------------------------------------------------------------------- -- Extension for records -instance (HLabelSet (HCons l ls), HSameLength ls vs) - => HExtend (LVPair l v) (RecordP ls vs) (RecordP (HCons l ls) (HCons v vs)) +instance (HLabelSet (l ': ls), SameLength ls vs) + => HExtend (Tagged l v) (RecordP ls vs) where - hExtend (LVPair v) (RecordP vs) = mkRecordP undefined (HCons v vs) + type HExtendR (Tagged l v) (RecordP ls vs) = RecordP (l ': ls) (v ': vs) + Tagged v .*. RecordP vs = mkRecordP Proxy (HCons v vs) + -- -------------------------------------------------------------------------- -- Record concatenation instance ( HLabelSet ls'' - , HAppend ls ls' ls'' - , HAppend vs vs' vs'' - , HSameLength ls'' vs'' + , HAppendR (RecordP ls vs) (RecordP ls' vs') ~ RecordP ls'' vs'' + , HAppendList ls ls' ~ ls'' + , HAppendList vs vs' ~ vs'' + , SameLength ls'' vs'' ) - => HAppend (RecordP ls vs) (RecordP ls' vs') (RecordP ls'' vs'') + => HAppend (RecordP ls vs) (RecordP ls' vs') where - hAppend (RecordP vs) (RecordP vs') = mkRecordP undefined (hAppend vs vs') + hAppend (RecordP vs) (RecordP vs') = mkRecordP Proxy (hAppend vs vs') +type instance HAppendR (RecordP ls vs) (RecordP ls' vs') = RecordP (HAppendR ls ls') (HAppendR vs vs') + -- -------------------------------------------------------------------------- -- Lookup operation @@ -110,22 +109,23 @@ -- implement it separately. The algorithm is familiar assq, -- only the comparison operation is done at compile-time -instance (HEq l l' b, HasFieldP' b l (RecordP (HCons l' ls) vs) v) - => HasField l (RecordP (HCons l' ls) vs) v where - hLookupByLabel = hLookupByLabelP' (undefined::b) +instance (HEq l l' b, HasFieldP' b l (l' ': ls) vs v) + => HasField l (RecordP (l' ': ls) vs) v where + hLookupByLabel = hLookupByLabelP' (Proxy :: Proxy b) -class HasFieldP' b l r v | b l r -> v where - hLookupByLabelP' :: b -> l -> r -> v +class HasFieldP' b l ls vs v | b l ls vs -> v where + hLookupByLabelP' :: Proxy b -> Label l -> RecordP ls vs -> v -instance HasFieldP' HTrue l (RecordP (HCons l ls) (HCons v vs)) v where +instance HasFieldP' True l (l ': ls) (v ': vs) v where hLookupByLabelP' _ _ (RecordP (HCons v _)) = v instance HasField l (RecordP ls vs) v - => HasFieldP' HFalse l (RecordP (HCons l' ls) (HCons v' vs)) v where + => HasFieldP' False l (l' ': ls) (v' ': vs) v where hLookupByLabelP' _ l (RecordP (HCons _ vs)) = hLookupByLabel l ((RecordP vs)::RecordP ls vs) +{- -- -------------------------------------------------------------------------- -- Delete operation hDeleteAtLabelP :: HProjectByLabelP l ls vs lso v vso => @@ -140,6 +140,7 @@ hUpdateAtLabelP l v rp@(RecordP vs) = RecordP (hUpdateAtHNat n v vs) where n = hFind l (labels_of_recordp rp) +-} -- -------------------------------------------------------------------------- -- Projection for records @@ -148,21 +149,21 @@ -- Project by a single label class HProjectByLabelP l ls vs lso v vso | l ls vs -> lso v vso where - h2ProjectByLabelP :: l -> RecordP ls vs -> (v,RecordP lso vso) + h2ProjectByLabelP :: Label l -> RecordP ls vs -> (v,RecordP lso vso) -instance (HEq l l' b, HProjectByLabelP' b l (HCons l' ls) vs lso v vso) - => HProjectByLabelP l (HCons l' ls) vs lso v vso where - h2ProjectByLabelP = h2ProjectByLabelP' (undefined::b) +instance (HEq l l' b, HProjectByLabelP' b l (l' ': ls) vs lso v vso) + => HProjectByLabelP l (l' ': ls) vs lso v vso where + h2ProjectByLabelP = h2ProjectByLabelP' (Proxy :: Proxy b) class HProjectByLabelP' b l ls vs lso v vso | b l ls vs -> lso v vso where - h2ProjectByLabelP' :: b -> l -> RecordP ls vs -> (v,RecordP lso vso) + h2ProjectByLabelP' :: Proxy b -> Label l -> RecordP ls vs -> (v,RecordP lso vso) -instance HProjectByLabelP' HTrue l (HCons l ls) (HCons v vs) ls v vs where +instance HProjectByLabelP' True l (l ': ls) (v ': vs) ls v vs where h2ProjectByLabelP' _ _ (RecordP (HCons v vs)) = (v,RecordP vs) instance (HProjectByLabelP l ls vs lso' v vso') - => HProjectByLabelP' HFalse l (HCons l' ls) (HCons v' vs) - (HCons l' lso') v (HCons v' vso') where + => HProjectByLabelP' False l (l' ': ls) (v' ': vs) + (l' ': lso') v (v' ': vso') where h2ProjectByLabelP' _ l (RecordP (HCons v' vs)) = let (v,RecordP vso) = h2ProjectByLabelP l ((RecordP vs)::RecordP ls vs) in (v, RecordP (HCons v' vso)) @@ -173,34 +174,36 @@ -- classes H2ProjectByLabels and H2ProjectByLabels' are declared in -- Record.hs -instance H2ProjectByLabels (HCons l ls) - (RecordP HNil HNil) (RecordP HNil HNil) - (RecordP HNil HNil) +{- need to change H2ProjectByLabels kind variables back to * from [*] +instance H2ProjectByLabels (l ': ls) + (RecordP '[] '[]) (RecordP '[] '[]) + (RecordP '[] '[]) where h2projectByLabels _ _ = (emptyRecordP,emptyRecordP) instance (HMember l' ls b, - H2ProjectByLabels' b ls (RecordP (HCons l' ls') vs') rin rout) - => H2ProjectByLabels ls (RecordP (HCons l' ls') vs') rin rout where - h2projectByLabels = h2projectByLabels' (undefined::b) + H2ProjectByLabels' b ls (RecordP (l' ': ls') vs') rin rout) + => H2ProjectByLabels ls (RecordP (l' ': ls') vs') rin rout where + h2projectByLabels = h2projectByLabels' (Proxy :: Proxy b) instance H2ProjectByLabels ls (RecordP ls' vs') (RecordP lin vin) rout => - H2ProjectByLabels' HTrue ls (RecordP (HCons l' ls') (HCons v' vs')) - (RecordP (HCons l' lin) (HCons v' vin)) rout where + H2ProjectByLabels' True ls (RecordP (l' ': ls') (v' ': vs')) + (RecordP (l' ': lin) (v' ': vin)) rout where h2projectByLabels' _ ls (RecordP (HCons v' vs')) = (RecordP (HCons v' vin), rout) where (RecordP vin,rout) = h2projectByLabels ls ((RecordP vs')::RecordP ls' vs') instance H2ProjectByLabels ls (RecordP ls' vs') rin (RecordP lo vo) => - H2ProjectByLabels' HFalse ls (RecordP (HCons l' ls') (HCons v' vs')) - rin (RecordP (HCons l' lo) (HCons v' vo)) where + H2ProjectByLabels' False ls (RecordP (l' ': ls') (v' ': vs')) + rin (RecordP (l' ': lo) (v' ': vo)) where h2projectByLabels' _ ls (RecordP (HCons v' vs')) = (rin, RecordP (HCons v' vo)) where (rin,RecordP vo) = h2projectByLabels ls ((RecordP vs')::RecordP ls' vs') - +-} +{- -- -------------------------------------------------------------------------- -- Subtyping for records diff --git a/HList.cabal b/HList.cabal --- a/HList.cabal +++ b/HList.cabal @@ -1,12 +1,27 @@ Name: HList -Version: 0.3.4.1 +Version: 0.5.4.0 Category: Data Synopsis: Heterogeneous lists -Description: HList is a record system providing strongly typed heterogenous lists, records, - type-indexed products (TIP) and co-products; licensed under the MIT X License. - . +Description: HList provides many operations to create and manipulate + heterogenous lists (HLists) whose length and element + types are known at compile-time. HLists are used to implement + . + * records + . + * variants + . + * type-indexed products (TIP) + . + * type-indexed co-products (TIC) + . + * keyword arguments + . User code should import "Data.HList" or "Data.HList.CommonMain" for a slightly more limited scope + . + The original design is described in , + though since that paper came out, the -XTypeFamiles extension has been used to + replace `TypeCast` with `~`. License: MIT License-File: LICENSE Author: 2004 Oleg Kiselyov (FNMOC, Monterey), Ralf Laemmel (CWI/VU, Amsterdam), @@ -15,88 +30,191 @@ Data-files: README, ChangeLog Cabal-version: >= 1.10 -Tested-With: GHC==7.6.2, GHC==7.7 +Tested-With: GHC==9.4.8, GHC==9.6.6, GHC==9.8.2, GHC==9.10.1 Build-Type: Simple Extra-Source-Files: - examples/*.hs, examples/broken/*.hs, examples/broken/*.lhs, - - examples/*.ref, - examples/*.out, - examples/broken/*.ref, Data/HList/broken/*.hs, Data/HList/obsolete/*.hs Source-Repository head - type: darcs - location: http://code.haskell.org/HList + type: git + location: https://bitbucket.org/HList/hlist +flag new_type_eq + Default: False + Manual: True + Description: use Data.Type.Equality.== to define the instance of HEq + instead of overlapping instances (in Data.HList.TypeEqO) + (needs ghc >= 7.8) + . + This version does not allow `HEq x [x] f` to lead to + f ~ False, unlike the version with overlapping instances. + See + library - Build-Depends: base >= 4 && < 5, template-haskell, ghc-prim, mtl, - tagged + Build-Depends: base >= 4.6 && < 4.21, + -- for Typeable '[] and '(:) with ghc-7.6 + base-orphans, + -- Data.Semigroup for ghc < 8 + semigroups, + template-haskell, + ghc-prim, + mtl, + tagged, + profunctors, + array + Exposed-modules: Data.HList, Data.HList.CommonMain, Data.HList.Data, + Data.HList.Dredge, Data.HList.FakePrelude, Data.HList.HArray, + Data.HList.HCurry, Data.HList.HList, Data.HList.HListPrelude, Data.HList.HOccurs, Data.HList.HTypeIndexed, + Data.HList.HSort, Data.HList.HZip, Data.HList.Keyword, Data.HList.Label3, + Data.HList.Label5, Data.HList.Label6, Data.HList.Labelable, Data.HList.MakeLabels, Data.HList.Record, Data.HList.RecordPuns, + Data.HList.RecordU, Data.HList.TIC, Data.HList.TIP, + Data.HList.TIPtuple, Data.HList.TypeEqO, Data.HList.Variant + Other-modules: LensDefs Default-Language: Haskell2010 - Ghc-Options: -Wall -fno-warn-missing-signatures + Ghc-Options: -Wall -fno-warn-missing-signatures -fno-warn-orphans Default-Extensions: ConstraintKinds DataKinds + DeriveDataTypeable EmptyDataDecls FlexibleContexts FlexibleInstances FunctionalDependencies + GeneralizedNewtypeDeriving GADTs KindSignatures MultiParamTypeClasses PolyKinds - RankNTypes, + RankNTypes ScopedTypeVariables + StandaloneDeriving TypeFamilies TypeOperators UndecidableInstances + Other-Extensions: CPP + TemplateHaskell + OverlappingInstances + if impl(ghc >= 8.6) + Default-Extensions: StarIsType + if impl(ghc >= 8.0) + Default-Extensions: UndecidableSuperClasses + + if impl(ghc < 7.7) + Cpp-options: -DOLD_TYPEABLE -DNO_CLOSED_TF + if impl(ghc >= 7.7) Default-Extensions: AllowAmbiguousTypes - StandaloneDeriving + RoleAnnotations + if impl(ghc > 7.9) + Ghc-Options: -fno-warn-unticked-promoted-constructors + -Wno-star-is-type + + if flag(new_type_eq) + Cpp-options: -DNEW_TYPE_EQ + Build-Depends: base >= 4.7 && < 4.21 + Test-Suite examples Type: exitcode-stdio-1.0 - Ghc-Options: -threaded - Main-Is: examples/runexamples.hs + Main-Is: HListExample.hs Default-Language: Haskell2010 - Build-Depends: base, hspec >= 1.7, directory, filepath, - process, syb, cmdargs, lens, HList, mtl + Hs-Source-Dirs: examples + Build-Depends: base < 4.21, hspec >= 1.7, directory, filepath, + hspec-expectations, + process, + syb, + cmdargs, + lens, + HList, + mtl, + QuickCheck, + array, + semigroups, + template-haskell + Other-Modules: + Properties.Common + HListExample.CmdArgs + HListExample.Datatypes2 + HListExample.Labelable + HListExample.MainGhcGeneric1 + HListExample.MainPosting051106 + HListExample.OverloadedLabels + HListExample.Prism + HListExample.Pun + HListExample.TIPTransform + HListExample.TIPTransformM + + if impl(ghc > 7.9) + Ghc-Options: -fno-warn-tabs + Test-Suite doctests Type: exitcode-stdio-1.0 Ghc-Options: -threaded - Main-Is: examples/rundoctests.hs - Build-Depends: base, doctest >= 0.8, process + if impl(ghc <= 7.9 ) && impl(ghc <= 7.11) + -- doctests include things like :t pred . maxBound, which + -- depending on the ghc version, comes out as one of + -- (Bounded a, Enum a) => ... + -- (Enum b, Bounded b) => ... + Build-Depends: base < 4.21, doctest >= 0.8, process + Buildable: False + Main-Is: rundoctests.hs + Hs-Source-Dirs: examples Default-Language: Haskell2010 + + +Test-Suite properties + Type: exitcode-stdio-1.0 + Build-Depends: base < 4.21, + hspec >= 1.7, + hspec-expectations, + HList, + lens, + mtl, + QuickCheck, + template-haskell, + array, + syb + Other-Modules: + Properties.Common + Properties.KW + Properties.LengthDependent + Properties.LengthDependentSplice + Properties.LengthIndependent + Main-Is: Properties.hs + Hs-Source-Dirs: examples + Default-Language: Haskell2010 + if impl(ghc <= 7.11) + build-depends: semigroups diff --git a/LensDefs.hs b/LensDefs.hs new file mode 100644 --- /dev/null +++ b/LensDefs.hs @@ -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)) diff --git a/README b/README --- a/README +++ b/README @@ -2,7 +2,7 @@ Contributors: Justin Bailey, Brian Bloniarz, Gwern Branwen, Einar Karttunen, - and Adam Vogt + Daniil Iaitskov and Adam Vogt The HList library and samples @@ -11,18 +11,19 @@ Getting the code -> darcs get http://code.haskell.org/HList +> git clone https://bitbucket.org/HList/hlist HList ---------------------------------------------------------------------- Pushing changes -You need an account at code.haskell.org +You need an account at bitbucket.org > cd HList -> darcs pull user@code.haskell.org:/srv/darcs/HList -> darcs record -> darcs push +> git clone git@bitbucket.org:HList/hlist.git +> git pull +> git commit --interactive +> git push ---------------------------------------------------------------------- @@ -35,19 +36,35 @@ since doing so would have implied inclusion of substantial packages, namely the underlying infrastructure for database access library. -You can get HList from Hackage or from Darcs: +You can get HList from Hackage or from bitbucket: $ cabal update && cabal install HList Or: -$ darcs get --partial http://code.haskell.org/HList/ +$ git clone https://bitbucket.org/HList/hlist HList $ cd HList; cabal install -The code works --- within the limits exercised in the source files --- -for GHC-7.6 and GHC-7.7. Older compilers are not supported. +The code was tested --- within the limits exercised in the source files --- +with GHC 9.4.8 through 9.10.1 and it may still work older versions possibly back to +GHC-7.6 +Older compilers are not supported. + One may run "cabal test" to check the distribution. -See ChangeLog for updates. +---------------------------------------------------------------------- +The library can be built and tested in the checked environment (with +compatible GHC, cabal and dependencies) provided by nix: + +$ nix-build # builds and runs tests +$ nix-shell --pure # drops into an isolated shell + +nix usually can be installed with a single line: + +$ sh <(curl -L https://nixos.org/nix/install) --no-daemon + +---------------------------------------------------------------------- + +See ChangeLog for updates. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env runhaskell -import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/examples/Datatypes1.hs b/examples/Datatypes1.hs deleted file mode 100644 --- a/examples/Datatypes1.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Datatypes1 where - --- The fout-n-mouth example - -newtype Key = Key Integer - deriving (Show,Eq,Ord) -newtype Name = Name String - deriving (Show,Eq) -data Breed = Cow | Sheep - deriving (Show,Eq) -newtype Price = Price Float - deriving (Show,Eq,Ord) -data Disease = BSE | FM - deriving (Show,Eq) diff --git a/examples/Datatypes2.hs b/examples/Datatypes2.hs deleted file mode 100644 --- a/examples/Datatypes2.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Datatypes2 where - -import Data.Typeable - --- The fout-n-mouth example --- (deriving Typeable only supported for GHC) - -newtype Key = Key Integer - deriving (Show,Eq,Ord,Typeable) -newtype Name = Name String - deriving (Show,Eq,Typeable) -data Breed = Cow | Sheep - deriving (Show,Eq,Typeable) -newtype Price = Price Float - deriving (Show,Eq,Ord,Typeable) -data Disease = BSE | FM - deriving (Show,Eq,Typeable) diff --git a/examples/FooBar.hs b/examples/FooBar.hs deleted file mode 100644 --- a/examples/FooBar.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# OPTIONS -fallow-undecidable-instances #-} -{-# OPTIONS -fallow-overlapping-instances #-} - -data Foo x y -class Bar x y | x -> y -class Zoo x y | x -> y - -{- - -Works for both GHC and Hugs - -instance Bar (Foo x y) y -instance Bar (Foo (Foo x y) z) z - --} - -{- - -Works for GHC but not Hugs - --} - -instance Zoo x r => Bar (Foo x y) r -instance Zoo x r => Bar (Foo (Foo x y) z) r - - diff --git a/examples/HListExample.hs b/examples/HListExample.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- tests based on HListExample +module Main (main) where + + +import Test.Hspec + + +import HListExample.Labelable +import HListExample.CmdArgs +import HListExample.MainGhcGeneric1 +-- import HListExample.MainPosting040607 +import HListExample.MainPosting051106 +import HListExample.Prism +import HListExample.Pun +import HListExample.TIPTransform +import HListExample.TIPTransformM +import HListExample.OverloadedLabels + + +main = hspec $ do + mainCmdargs + mainLabelable + mainGhcGeneric1 + mainPosting051106 + mainPrism + mainPun + mainTIPTransform + mainTTIPM + mainOverloadedLabels + + + + + + diff --git a/examples/HListExample/CmdArgs.hs b/examples/HListExample/CmdArgs.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/CmdArgs.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TemplateHaskell #-} +module HListExample.CmdArgs where + + +import Data.Generics +import Control.Lens +import Test.Hspec +import Properties.Common + +import Data.HList.CommonMain + +import System.Console.CmdArgs (cmdArgs) +import System.Environment (withArgs) + + +{- + +An example showing off the data instance for Record / Variant / TIP / TIC + +Also a use of cmdArgs + +Note that ghc-7.8.2 does not have (or can produce) instances of typeable +for types of kind Symbol (ie. promoted strings): +, so for now use the Label3 +style + +-} + +#define USE_LABEL3 __GLASGOW_HASKELL__ == 708 + +#if USE_LABEL3 +makeLabels3 "examples_cmdargs" (words "x y z tic") +makeLabels3 "optV" (words "optA optB optC") +#else +makeLabels6 (words "x y z tic") +makeLabels6 (words "optA optB optC") +#endif + +makeLabelable "abc df" + +#if USE_LABEL3 +v = (optA .*. optB .*. optC .*. emptyProxy) + `zipTagged` (Proxy :: Proxy '[Int,Char,Double]) +#else +v = Proxy :: Proxy '[Tagged "optA" Int, Tagged "optB" Char, Tagged "optC" Double] +#endif + +type Z' = TagR [Int, Char, Double] +-- type Z' = [Tagged Int Int, Tagged Char Char, Tagged Double Double] + +d0 = x .=. (5 :: Int) + .*. y .=. True + .*. z .=. mkVariant optC (1 :: Double) v + .*. tic .=. mkTIC' 'x' (Proxy :: Proxy Z') + .*. emptyRecord + +-- the equivalent ordinary record for reference +data E = E { a :: Int, b :: Bool } + deriving (Show, Data, Typeable) + +data Opt = OptA Int | OptB Char | OptC Double + deriving (Show, Data, Typeable) + +e0 = E 5 True + +mainCmdargs = describe "cmdargs/Data" $ do + it "variant show" $ + mkVariant optC 1 v `shouldShowTo` "V{optC=1.0}" + + -- increment V{optC=1.0} via data instance + it "gmapT" $ + gmapT (mkT ((+1) :: Double -> Double)) (mkVariant optC 1 v) + `shouldShowTo` "V{optC=2.0}" + + it "d0" $ + d0 `shouldShowTo` + "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}" + + it "modify d0's Bool children" $ + gmapT (mkT not) d0 `shouldShowTo` + "Record{x=5,y=False,z=V{optC=1.0},tic=TIC{char='x'}}" + + it "modify d0's Int children" $ + gmapT (mkT (+(1::Int))) d0 `shouldShowTo` + "Record{x=6,y=True,z=V{optC=1.0},tic=TIC{char='x'}}" + + it "modify d0's Char children (none)" $ + gmapT (mkT (succ :: Char -> Char)) d0 `shouldShowTo` + "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}}" + + it "modify d0's Char grandchildren" $ + everywhere (mkT (succ :: Char -> Char)) d0 `shouldShowTo` + "Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='y'}}" + +#if __GLASGOW_HASKELL__ != 706 + -- ghc-7.6.3 fails with all uses of dredge: + -- Kind incompatibility when matching types: + -- Const (Data.Monoid.First Double) Double :: AnyK + -- Const (Data.Monoid.First Double) Double :: * + + it "dredge optC" $ + d0 & dredge optC +~ 1 `shouldShowTo` + "Record{x=5,y=True,z=V{optC=2.0},tic=TIC{char='x'}}" +#endif + + -- theB is like a TIP the unsafe lookup function applied + let theB :: Typeable a => a + theB = error "theB" + `extB` (1::Int) + `extB` True + `extB` (2.5::Double) + `extB` 'b' + `extB` mkVariant optC theB v + `extB` mkTIC' (theB :: Char) (Proxy :: Proxy Z') + + it "fromConstrB" $ + fromConstrB theB undefined `asTypeOf` d0 `shouldShowTo` + "Record{x=1,y=True,z=V{optC=2.5},tic=TIC{char='b'}}" + + it "cmdargs built-in data" $ + withArgs ["-a=4", "-b=False" ] (cmdArgs e0) `shouldReturnShowTo` + "E {a = 4, b = False}" + + -- drop the tic and variant-containing fields: cmdargs doesn't support + -- it. Cmdargs doesn't support fields containing + -- `data Opt = OptA Int | OptB Char` either + let dRec = d0 & from hListRecord %~ (hInit . hInit) + + it "dRec" $ + dRec `shouldShowTo` + "Record{x=5,y=True}" + + it "cmdargs Record" $ + withArgs ["-x=4", "-y=False"] (cmdArgs dRec) `shouldReturnShowTo` + "Record{x=4,y=False}" + diff --git a/examples/HListExample/Datatypes2.hs b/examples/HListExample/Datatypes2.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/Datatypes2.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module HListExample.Datatypes2 where + +import Data.Typeable + +-- The fout-n-mouth example +-- (deriving Typeable only supported for GHC) + +newtype Key = Key Integer + deriving (Show,Eq,Ord,Typeable) +newtype Name = Name String + deriving (Show,Eq,Typeable) +data Breed = Cow | Sheep + deriving (Show,Eq,Typeable) +newtype Price = Price Float + deriving (Show,Eq,Ord,Typeable) +data Disease = BSE | FM + deriving (Show,Eq,Typeable) diff --git a/examples/HListExample/Labelable.hs b/examples/HListExample/Labelable.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/Labelable.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds, + GADTs, ConstraintKinds #-} +{- | Demonstrates @hLens'@ + +may be worthwhile to have a lens-free test suite, doing stuff like: + +> case x (Identity . (++"there")) r of Identity t -> t + +-} +module HListExample.Labelable where +import Data.HList.CommonMain +import Control.Lens + +import Text.Read + +import Properties.Common +import Test.Hspec + + +makeLabelable "lbX lbY" + +#if __GLASGOW_HASKELL__ < 707 +#define INT_SIG_76 :: Int +#else +#define INT_SIG_76 +#endif + +r = lbX .==. "hi" .*. + lbY .==. (lbY .==. 321 .*. lbX .==. 123 .*. emptyRecord) .*. + emptyRecord + +mainLabelable = describe "labelable" $ do + it "lookup" $ do + r ^. lbX `shouldShowTo` "\"hi\"" + + -- ghc-7.6 doesn't default when r is involved lower down, + -- while 7.8.2 does + (r ^. lbY . lbY INT_SIG_76) `shouldShowTo` "321" + (r ^. lbY . lbX INT_SIG_76) `shouldShowTo` "123" + + it "modify" $ do + r & lbX .~ () `shouldShowTo` + "Record{lbX=(),lbY=Record{lbY=321,lbX=123}}" + + r & lbY . lbY .~ "xy" `shouldShowTo` + "Record{lbX=\"hi\",lbY=Record{lbY=\"xy\",lbX=123}}" + + it "read/show" $ do + let rString = "Record{lbX=\"hi\",lbY=Record{lbY=321,lbX=123}}" + + r `shouldShowTo` rString + + readMaybe rString `asTypeOf` Just r + `shouldBe` Just r + + -- the read instance does not reorder labels + let rStringPerm = "Record{lbY=Record{lbY=321,lbX=123},lbX=\"hi\"}" + readMaybe rStringPerm `asTypeOf` Just r + `shouldBe` Nothing + + -- but we can reorder this way + (r ^. rearranged) `asTypeOf` (undefined :: Record '[Tagged "lbY" t, Tagged "lbX" s]) + `shouldShowTo` rStringPerm diff --git a/examples/HListExample/MainGhcGeneric1.hs b/examples/HListExample/MainGhcGeneric1.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/MainGhcGeneric1.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +{- + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + This is a main module for exercising a model with generic type + cast and generic type equality. + +-} + +module HListExample.MainGhcGeneric1 (mainGhcGeneric1) where + +import HListExample.Datatypes2 +import Data.HList.CommonMain +import Control.Lens + +import Properties.Common +import Test.Hspec + +import Control.Monad.Writer + +-- -------------------------------------------------------------------------- + +type Animal = '[Key,Name,Breed,Price] + +angus :: HList Animal +angus = HCons (Key 42) + (HCons (Name "Angus") + (HCons Cow + (HCons (Price 75.5) + HNil))) + +tlist1 = hFoldr (HSeq HPrint) (return () :: IO ()) angus + +testBasic = do + it "basic" $ do + -- tlist1 does IO. The equivalent using Writer + let f = HSeq $ HComp (tell . (:[])) HShow + f2 = Fun (tell . (:[]) . show) :: Fun Show (Writer [String] ()) + + angusStr = ["Key 42", "Name \"Angus\"", "Cow", "Price 75.5" ] + + execWriter (hFoldr f (return ()) angus) `shouldBe` + angusStr + + execWriter (hFoldr (HSeq f2) (return ()) angus) `shouldBe` + angusStr + + + hAppend angus angus `shouldShowTo` + "H[Key 42,Name \"Angus\",Cow,Price 75.5,Key 42,Name \"Angus\",Cow,Price 75.5]" + + +testHArray = do + it "HArray" $ do + hProjectByHNats (hNats (HCons hZero (HCons hZero HNil))) angus `shouldShowTo` + "H[Key 42]" + + -- Before: + -- H[Key 42, Key 42] + -- XXX I don't duplicate at present! + hProjectByHNats (hNats (HCons hZero (HCons (hSucc hZero) HNil))) angus `shouldShowTo` + "H[Key 42,Name \"Angus\"]" + + hProjectByHNats (undefined::Proxy ['HZero, 'HSucc 'HZero]) angus `shouldShowTo` + "H[Key 42,Name \"Angus\"]" + + hProjectAwayByHNats (hNats (HCons hZero HNil)) angus `shouldShowTo` + "H[Name \"Angus\",Cow,Price 75.5]" + + hSplitByHNats + (undefined::Proxy ['HZero, 'HSucc 'HZero]) + angus + `shouldShowTo` + "(H[Key 42,Name \"Angus\"],H[Cow,Price 75.5])" + + + it "HOccurs" $ do + (hOccurs angus :: Breed) `shouldShowTo` "Cow" + hOccurs angus `shouldBe` Cow + + hOccurs (hBuild 1 ^. from tipHList) `shouldShowTo` "1" + + (null $ hOccurs $ hBuild [] ^. from tipHList) `shouldBe` True + (hProject angus :: HList '[Key, Name]) `shouldShowTo` + "H[Key 42,Name \"Angus\"]" + + + it "TypeIndexed" $ do + let typeIdx1 = hDeleteMany (undefined::Proxy Name) angus + typeIdx2 = BSE .*. angus + typeIdx1 `shouldShowTo` "H[Key 42,Cow,Price 75.5]" + typeIdx2 `shouldShowTo` "H[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]" + + hUpdateAt Sheep typeIdx1 `shouldShowTo` + "H[Key 42,Sheep,Price 75.5]" + + hDeleteAt (undefined::Proxy Breed) typeIdx2 `shouldShowTo` + "H[BSE,Key 42,Name \"Angus\",Price 75.5]" + + hProjectBy (undefined::Proxy '[Breed]) angus `shouldShowTo` "H[Cow]" + + hProject angus `shouldBe` HCons Cow HNil + + -- doesn't work + -- hProjectBy Proxy angus `shouldBe` HCons Cow HNil + + hSplitBy (undefined:: Proxy '[Breed]) angus `shouldShowTo` + "(H[Cow],H[Key 42,Name \"Angus\",Price 75.5])" + +testTIP = do + -- | + -- This example from the TIR paper challenges singleton lists. + -- Thanks to the HW 2004 reviewer who pointed out the value of this example. + -- We note that the explicit type below is richer than the inferred type. + -- This richer type was needed for making this operation more polymorphic. + -- That is, /a)/ would not work without the explicit type, + -- while /b/ would: + -- + -- > a) ((+) (1::Int)) $ snd $ tuple oneTrue + -- > b) ((+) (1::Int)) $ fst $ tuple oneTrue + -- + -- As of 2014, type signatures are not needed to define tipyTuple. + it "tipyTuple" $ do + let tuple l = tipyTuple l + + -- oneTrue :: TIP (TagR [Int, Bool]) -- inferred + -- oneTrue :: TIP '[Tagged Int Int, Tagged Bool Bool] -- expanded out + oneTrue = (1::Int) .*. True .*. emptyTIP + + case tuple oneTrue of + (a,b) -> (a+(1::Int), not b) `shouldShowTo` "(2,False)" + + not (fst (tuple oneTrue)) `shouldShowTo` "False" + tuple oneTrue `shouldBe` (1::Int,True) + + (((+) (1::Int)) $ fst $ tuple oneTrue) `shouldBe` 2 + (((+) (1::Int)) $ snd $ tuple oneTrue) `shouldBe` 2 + + + it "tip" $ do + hOccurs myTipyCow `shouldBe` Cow + (BSE .*. myTipyCow) `shouldShowTo` "TIPH[BSE,Key 42,Name \"Angus\",Cow,Price 75.5]" + -- (Sheep .*. myTipyCow) `shouldBe` _ + {- if we uncomment the line above, we get the type error + about the violation of the TIP condition: Breed type + occurs twice. + + No instance for (Fail * (TypeFound Breed)) + -} + + (Sheep .*. hDeleteAtLabel (Label :: Label Breed) myTipyCow) + `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]" + + (Sheep .*. (myTipyCow .-. (Label :: Label Breed))) + `shouldShowTo` "TIPH[Sheep,Key 42,Name \"Angus\",Price 75.5]" + + tipyUpdate Sheep myTipyCow + `shouldShowTo` "TIPH[Key 42,Name \"Angus\",Sheep,Price 75.5]" + + + + +myTipyCow = tipHList # angus -- lens # + +animalKey :: ( SubType l (TIP Animal) -- explicit + , HOccurs Key l -- implicit + ) => l -> Key +animalKey = hOccurs + +animalish :: SubType l (TIP Animal) => l -> l +animalish = id +animalKey' l = hOccurs (animalish l) :: Key + + +makeLabels3 "MyNS" (words "key name breed price") +{- ^ makeLabels3 generates something like +data MyNS = MyNS -- a name space for record labels + +key = firstLabel MyNS (undefined::DKey) +name = nextLabel key (undefined::DName) +breed = nextLabel name (undefined::DBreed) +price = nextLabel breed (undefined::DPrice) + +data DKey; instance Show DKey where show _ = "key" +data DName; instance Show DName where show _ = "name" +data DBreed; instance Show DBreed where show _ = "breed" +data DPrice; instance Show DPrice where show _ = "price" + +-} + +unpricedAngus = key .=. (42::Integer) + .*. name .=. "Angus" + .*. breed .=. Cow + .*. emptyRecord + + +testRecords = describe "testRecords" $ it "tests" $ do + + unpricedAngus `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Cow}" + unpricedAngus .!. breed `shouldShowTo` "Cow" + + let test3 = hDeleteAtLabel breed unpricedAngus + + test3 + `shouldShowTo` "Record{key=42,name=\"Angus\"}" + + (breed .=. Sheep .@. unpricedAngus) + `shouldShowTo` "Record{key=42,name=\"Angus\",breed=Sheep}" + + let test4 = price .=. 8.8 .*. unpricedAngus + + test4 + `shouldShowTo` "Record{price=8.8,key=42,name=\"Angus\",breed=Cow}" + + hProjectByLabels (labelsOf (breed `HCons` price `HCons` HNil)) test4 + `shouldShowTo` "Record{price=8.8,breed=Cow}" + + -- XXX extra Label shouldn't be needed? + -- alternatively it could be a compile-time error... + -- hProjectByLabels (hEndP $ hBuild breed price) test4 + -- `shouldShowTo` "Record{price=8.8,breed=Cow}" + + -- test7 should be the same as test4 but + -- with the different order of labels + (newLVPair breed Sheep) .*. test3 + `shouldShowTo` "Record{breed=Sheep,key=42,name=\"Angus\"}" + + +type AnimalCol = TagR [Key,Name,Breed,Price] + + +testTIC = describe "TIC" $ do + it "show" $ + (myCol :: TIC AnimalCol) `shouldShowTo` "TIC{breed=Cow}" + it "hOccurs found" $ + (hOccurs myCol :: Maybe Breed) `shouldBe` Just Cow + it "hOccurs absent" $ + (hOccurs myCol :: Maybe Price) `shouldBe` Nothing + +myCol = mkTIC Cow :: TIC AnimalCol +{- + +*TIC> mkTIC "42" :: TIC AnimalCol +Type error ... + +*TIC> hOccurs myCol :: Maybe String +Type error ... + +-- both of the these type errors could be better +-- (on ghc-7.10.3), Any is used to satisfy FD coverage condition, but the +-- TypeError context should be printed instead +:170:1: + Couldn't match type ‘Data.HList.CommonMain.Any’ with ‘[Char]’ + In the expression: mkTIC "42" :: TIC AnimalCol + In an equation for ‘it’: it = mkTIC "42" :: TIC AnimalCol +-} + +testVariant = describe "Variant" $ it "test" $ do + testVar1 `shouldShowTo` "V{name=\"angus\"}" + (testVar1 .!. key) `shouldBe` Nothing + (testVar1 .!. name) `shouldBe` Just "angus" + where + testVar1 = mkVariant name "angus" animalVar + +animalVar = asProxy $ + key .=. (undefined :: Integer) + .*. name .=. (undefined :: String) + .*. breed .=. (undefined :: Breed) + .*. emptyRecord + + +asProxy :: proxy a -> Proxy a +asProxy _ = Proxy + +mainGhcGeneric1 = describe "mainGhcGeneric1" $ do + testBasic + testHArray + testTIP + testRecords + testTIC + testVariant diff --git a/examples/HListExample/MainPosting051106.hs b/examples/HListExample/MainPosting051106.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/MainPosting051106.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ > 906 +{-# LANGUAGE TypeOperators #-} +#endif +module HListExample.MainPosting051106 where + +-- Needed for a reply to the Haskell mailing list + +import Data.HList.CommonMain hiding (Comp(..)) +import Properties.Common +import Test.Hspec + +mainPosting051106 = describe "hComposeList (a -> H[a -> b,b -> c,c -> d] -> d)" $ do + it "defined here" $ + comp "abc" `shouldShowTo` "8" + + it "defined in HList" $ + hComposeList test2 "abc" `shouldShowTo` "8" + +test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil)) +test2 = length .*. (+1) .*. (*2) .*. HNil + +data Comp + +{- simpler class. wouldn't work with test2. The original HFoldr won't work with + - Apply anymore. +instance Apply Comp (x -> y,y -> z) + where + type ApplyR Comp (x -> y,y -> z) = x -> z + apply _ (f,g) = g . f + -} + +-- `~` is (built-in) TypeCast mentioned below +instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz) + => ApplyAB Comp xyz xz + where + applyAB _ (f,g) = g . f + +-- Function composition based on type code works. + +comp = hFoldr (undefined::Comp) (id::Int -> Int) test + +-- Function composition based on normal polymorphism doesn't +-- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test + +{- + +From Ralf.Lammel at microsoft.com Mon Nov 7 00:11:01 2005 +From: Ralf.Lammel at microsoft.com (Ralf Lammel) +Date: Sun Nov 6 23:50:27 2005 +Subject: [Haskell-cafe] Type classes and hFoldr from HList +Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com> + +Hi Greg, + +Since hfoldr is right-associative, I prefer to reorder your list of +functions as follows: + +> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons +((*2)::(Int->Int)) HNil)) + +Note that I also annotated length with its specific type. +(If you really wanted to leave things more polymorphic, you would need +to engage in TypeCast.) + +Providing a specific Apply instance for (.) is not necessary, strictly +necessary. We could try to exploit the normal function instance for +Apply. + +Let me recall that one here for convenience: + +>instance Apply (x -> y) x y +> where +> apply f x = f x + +Let me also recall the hFoldr instances: + +>class HList l => HFoldr f v l r | f v l -> r +> where +> hFoldr :: f -> v -> l -> r + +>instance HFoldr f v HNil v +> where +> hFoldr _ v _ = v + +>instance ( HFoldr f v l r +> , Apply f (e,r) r' +> ) +> => HFoldr f v (HCons e l) r' +> where +> hFoldr f v (HCons e l) = apply f (e,hFoldr f v l) + + +To fit in (.), we would flip and uncurry it. +So we could try: + +comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test + +This wouldn't work. +The trouble is the required polymorphism of the first argument of +hFoldr. +The type of that argument as such is polymorphic. +However, this polymorphism does not survive type class parameterization. +You see this by looking at the HCons instance of HFoldr. +The different occurrences of "f" would need to be used at different +types. +This would only work if the type class parameter f were instantiated by +the polymorphic type of (uncurry (flip (.))). (And even then we may need +something like TypeCast.) + +What you can do is define a dedicated *type code* for composition. + +comp = hFoldr (undefined::Comp) (id::Int -> Int) test + +data Comp + +instance Apply Comp (x -> y,y -> z) (x -> z) + where + apply _ (f,g) = g . f + + +Ralf + + +> -----Original Message----- +> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe- +> bounces@haskell.org] On Behalf Of Greg Buchholz +> Sent: Sunday, November 06, 2005 7:01 PM +> To: haskell-cafe@haskell.org +> Subject: [Haskell-cafe] Type classes and hFoldr from HList +> +> +> I was playing around with the HList library from the paper... +> +> Strongly typed heterogeneous collections +> http://homepages.cwi.nl/~ralf/HList/ +> +> ...and I thought I'd try to fold the composition function (.) through +a +> heterogeneous list of functions, using hFoldr... +> +> >{-# OPTIONS -fglasgow-exts #-} +> >{-# OPTIONS -fallow-undecidable-instances #-} +> > +> >import CommonMain +> > +> >main = print $ comp "abc" +> > +> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons +length +> HNil)) +> > +> >comp = hFoldr (.) id test +> > +> >instance Apply (a -> b -> c -> d) (a, b) (c -> d) +> > where +> > apply f (a,b) = f a b +> +> ...but it fails with the following type error... +> +> ]Compiling Main ( compose.hs, interpreted ) +> ] +> ]compose.hs:10:7: +> ] No instances for (Apply ((b -> c) -> (a -> b) -> a -> c) +> ] (Int -> Int, r) +> ] ([Char] -> a3), +> ] Apply ((b -> c) -> (a -> b) -> a -> c) (Int -> +Int, +> r1) r, +> ] Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] -> +> Int, a1 ->a1) r1) +> ] arising from use of `hFoldr' at compose.hs:10:7-12 +> ] Probable fix: +> ] add an instance declaration for (Apply ((b -> c) -> (a -> b) -> +a - +> > c) +> ] (Int -> Int, r) +> ] ([Char] -> a3), +> ] Apply ((b -> c) -> (a -> b) -> +a - +> > c) +> ](Int -> Int, r1) r, +> ] Apply ((b -> c) -> (a -> b) -> +a - +> > c) +> ]([a2] -> Int, a1 -> a1) r1) +> ] In the definition of `comp': comp = hFoldr (.) id test +> +> ...Anyway, I couldn't quite tell whether I was using hFoldr +incorrectly, +> or if I needed to have more constraints placed on the construction of +> "test", or if needed some sort of type-level function that resolves... +> +> Apply ((b -> c) -> (a -> b) -> a -> c) +> +> ...into (a -> c), or something else altogether. I figured someone +might +> be able to help point me in the right direction. + +-} diff --git a/examples/HListExample/OverloadedLabels.hs b/examples/HListExample/OverloadedLabels.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/OverloadedLabels.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedLabels, TypeOperators, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes, PolyKinds, TypeApplications, DataKinds #-} +module HListExample.OverloadedLabels where + +import Data.HList.CommonMain +import GHC.OverloadedLabels +import Control.Lens +import Data.HList.Labelable +import Properties.Common +import Test.Hspec +import GHC.TypeLits + +{- | -XOverloadedLabels expands #foo into `hLens' (Label :: Label "foo")` + + +Not in Data.HList.Labelable because it would overlap other uses of IsLabel +-} +instance (Labelable x r s t a b, x ~ x_, + lens ~ ((a `p` f b) `to` (r s `p` f (r t))), + ty ~ LabelableTy r, + LabeledOpticF ty f, + LabeledOpticP ty p, + LabeledOpticTo ty x to + ) => IsLabel x_ lens where + fromLabel = hLens' (Label :: Label x) + + +{- | hLens' where the `x` type parameter must be supplied by -XTypeApplications. +In other words these are all equivalent: + +> hLens' (Label :: Label "abc") +> hLens' (Label @"abc") +> hL @"abc" +> `abc -- HListPP + +-} +hL :: forall x r s t a b to p f. + Labelable x r s t a b => + LabeledOptic x r s t a b +hL = hLens' (Label :: Label x) + + +r = #abc .==. 3 .*. emptyRecord + + +mainOverloadedLabels = describe "-XOverloadedLabels" $ do + it "lookup" $ do + r ^. #abc `shouldShowTo` "3" + r ^. hL @"abc" `shouldShowTo` "3" diff --git a/examples/HListExample/Prism.hs b/examples/HListExample/Prism.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/Prism.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE QuasiQuotes #-} -- for pun +{-# LANGUAGE TemplateHaskell #-} +module HListExample.Prism where + + +import Test.Hspec +import Properties.Common + +import Data.HList.CommonMain +import Data.HList.Labelable (hLens') +import Control.Lens + +-- generate left = Label :: Label "left" +makeLabels6 (words "left right up down") + +--- define the Labelable labels manually +left_ = hLens' left +right_ = hLens' right +up_ = hLens' up +down_ = hLens' down + +-- this definition is needed to decide what order +-- to put the fields in, as well as their initial types +r = [pun|right left up|] where + left = 'a' + right = 2 :: Int + up = 2.3 :: Double + +r2 = down_ .==. v .*. r + +v = mkVariant left 'x' r + +mainPrism = do + it "inspect v with hPrism" $ do + v ^? hPrism left `shouldShowTo` "Just 'x'" + v ^? hPrism right `shouldBe` Nothing + v ^? hPrism up `shouldBe` Nothing + v2 ^? hPrism left `shouldShowTo` "Just ()" + + it "inspect v with hPrism through Labelable" $ do + v ^? left_ `shouldShowTo` "Just 'x'" + v ^? right_ `shouldBe` Nothing + v ^? up_ `shouldBe` Nothing + v2 ^? left_ `shouldShowTo` "Just ()" + + it "Setting the missing tag does nothing" $ do + set right_ () v `shouldShowTo` "V{left='x'}" + + set _Right () (Left 'x') -- prisms for Either do the same thing + `shouldShowTo` "Left 'x'" + + it "compose prism" $ do + v3 ^? up_.up_ `shouldBe` Nothing + v3 ^? left_ `shouldShowTo` "Just 'x'" + + v4 ^? left_.left_ `shouldShowTo` "Just \"leftleft\"" + + it "compose lens.prism" $ do + r2 ^? down_.left_ `shouldShowTo` "Just 'x'" + r2 ^? down_.right_ `shouldBe` Nothing + + let du = down_.up_ + r2 ^? du `shouldBe` Nothing + + it "extension" $ do + v5 ^? down_ `shouldBe` Just "hi" + v6 ^? down_ `shouldBe` Just "hi" + v7 ^? down_ `shouldBe` Nothing + v7 ^? left_ `shouldBe` Just 'x' + + it "show" $ do + vs `shouldShowTo` + "Record{v=V{left='x'},\ + \v2=V{left=()},\ + \v2'=V{left=()},\ + \v3=V{left='x'},\ + \v4=V{left=V{left=\"leftleft\"}},\ + \v5=V{down=\"hi\"},\ + \v6=V{down=\"hi\"},\ + \v7=V{left='x'}}" + + -- works in ghci. Probably need -XExtendedDefaultRules + -- wX `shouldShowTo` "V{x='a'}" + -- wY `shouldShowTo` "V{y=2.5}" + [wX,wY] `shouldShowTo` "[V{x='a'},V{y=2.5}]" + + -- :t wX + -- > wX :: Variant '[Tagged "x" Char, Tagged "y" y] + -- + -- > :t wY + -- > wY :: Variant '[Tagged "x" x, Tagged "y" Double] + -- + -- ghc doesn't need to decide on a type for values that + -- have no influence on the final result + it "type partly defined" $ do + wX ^? hLens' (Label :: Label "x") + `shouldShowTo` "Just 'a'" + wY ^? hLens' (Label :: Label "y") + `shouldShowTo` "Just 2.5" + + +wX = mkVariant (Label :: Label "x") 'a' wProto +wY = mkVariant (Label :: Label "y") (2.5 :: Double) wProto + +wProto = undefined :: Record + '[Tagged "x" x, Tagged "y" y] + +vs = [pun| v v2 v2' v3 v4 v5 v6 v7 |] + +-- note that we can change the type of the 'x' field +-- from Char to () +v2 = set (hPrism left) () v + + +-- or with the "better" label +v2' = set left_ () v + + +v3 = v & up_ .~ v & up_.up_ .~ "upup" +v4 = v & left_ .~ v & left_.left_ .~ "leftleft" +v5 = down .=. Just "hi" .*. v +v6 = down_ .==. Just "hi" .*. v +v7 = down .=. (Nothing :: Maybe String) .*. v diff --git a/examples/HListExample/Pun.hs b/examples/HListExample/Pun.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/Pun.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} +-- more examples for record puns +module HListExample.Pun where +import Data.HList.CommonMain + +import Test.Hspec +import Properties.Common + +makeLabels6 (words "a b c") + + +r = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord +r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord + + +p1 ( (.!. b) -> (b@((.!. a) -> a))) = (a,b) + +p2 [pun| b @ {a} |] = (a, b) + +-- same as p2, but gives a warning +-- p3 [pun| b @ a |] = (a, b) + +p4 [pun| b{a} |] = a -- b is not bound + +-- adds `x' and `y' into a field called r +e1 = let x = 1; y = "hi" in [pun| r @ { x y } |] + +-- updates the `c' field +e2 = let c = 1; y = "hi" in [pun| r @ { c y } |] + +-- same as e1, but doesn't use a pre-existing r +e3 = let x = 1; y = "hi" in [pun| r { x y } |] + + +mainPun = describe "pun quasiquoter" $ do + it "pattern" $ do + p1 r `shouldShowTo` "(3,Record{a=3})" + p2 r `shouldShowTo` "(3,Record{a=3})" + p4 r `shouldBe` 3 + + it "expression" $ do + e1 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\",c=\"c\",b=Record{a=3}}}" + e2 `shouldShowTo` "Record{r=Record{c=1,y=\"hi\",b=Record{a=3}}}" + e3 `shouldShowTo` "Record{r=Record{x=1,y=\"hi\"}}" + diff --git a/examples/HListExample/TIPTransform.hs b/examples/HListExample/TIPTransform.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/TIPTransform.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-} + +-- Transforming a TIP: applying to a TIP a (polyvariadic) function +-- that takes arguments from a TIP and updates the TIP with the result. +-- +-- In more detail: we have a typed-indexed collection TIP and we +-- would like to apply a transformation function to it, whose argument +-- types and the result type are all in the TIP. The function should locate +-- its arguments based on their types, and update the TIP +-- with the result. The function may have any number of arguments, +-- including zero; the order of arguments should not matter. + +-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009. +-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html +-- The problem is an interesting variation of the keyword argument problem. + +module HListExample.TIPTransform where + +import Data.HList.CommonMain +import Data.Typeable + +import Properties.Common +import Test.Hspec + +-- We start with the examples + +newtype MyVal = MyVal Int deriving (Show, Typeable) + +-- or if no typeable, use +-- instance ShowLabel MyVal where showLabel _ = "MyVal" + +tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP + + +mainTIPTransform = describe "tipTransform" $ it "all" $ do + tip1 `shouldShowTo` "TIPH[MyVal 20,1,True]" + + -- Update the Int component of tip1 to 2. The Int component must + -- exist. Otherwise, it is a type error + ttip (2::Int) tip1 `shouldShowTo` + "TIPH[MyVal 20,2,True]" + + -- Negate the boolean component of tip1 + ttip not tip1 `shouldShowTo` + "TIPH[MyVal 20,1,False]" + + -- Update the Int component from the values of two other components + ttip (\(MyVal x) y -> x+y) tip1 `shouldShowTo` + "TIPH[MyVal 20,21,True]" + + -- Update the MyVal component from the values of three other components + ttip (\b (MyVal x) y -> MyVal $ if b then x+y else 0) tip1 + `shouldShowTo` + "TIPH[MyVal 21,1,True]" + + -- The same but with the permuted argument order. + -- The order of arguments is immaterial: the values will be looked up using + -- their types + ttip (\b y (MyVal x)-> MyVal $ if b then x+y else 0) tip1 + `shouldShowTo` + "TIPH[MyVal 21,1,True]" + +-- The implementation +-- part of HList proper now diff --git a/examples/HListExample/TIPTransformM.hs b/examples/HListExample/TIPTransformM.hs new file mode 100644 --- /dev/null +++ b/examples/HListExample/TIPTransformM.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} -- !TF +-- Transforming a TIP: applying to a TIP a (polyvariadic) function +-- that takes arguments from a TIP and updates the TIP with the result. +-- The monadic version. +-- This file contains two versions of the code. +-- The comments -- !Simple and -- !TF distinguish the versions +-- +-- In more detail: we have a typed-indexed collection TIP and we +-- would like to apply a transformation function to it, whose argument +-- types and the result type are all in the TIP. The function should locate +-- its arguments based on their types, and update the TIP +-- with the result. The function may have any number of arguments, +-- including zero; the order of arguments should not matter. + +-- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009. +-- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html +-- The problem is an interesting variation of the keyword argument problem. +-- In March 2010, Andrew Frank extended the problem for monadic operations. +-- This is the monadic version of TIPTransform.hs in the present directory. + + +module HListExample.TIPTransformM where + +import Data.HList.CommonMain +import Data.Typeable +import Control.Monad.Identity +import Control.Monad.Writer + +import Test.Hspec +import Properties.Common + +-- We start with the examples + +newtype MyVal = MyVal Int deriving (Show,Typeable) + +-- A specialized version of return for the Identity monad. +-- It is needed only for the Simple version of the code, +-- to tell the type checker the monad in which the computation is +-- taking place. +-- For the TF version of the code, we can use the ordinary return +-- in place of retI. +retI :: a -> Identity a +retI = return + +-- A sample TIP +tip1 = MyVal 20 .*. (1::Int) .*. True .*. (3.5::Float) .*. emptyTIP +-- TIP (HCons (MyVal 20) (HCons 1 (HCons True (HCons 3.5 HNil)))) + +-- Update the Int component of tip1 to 2. The Int component must +-- exist. Otherwise, it is a type error +-- tip2 = runIdentity $ ttipM (retI (2::Int)) tip1 -- !Simple +tip2 = runIdentity $ ttipM (return (2::Int)) tip1 -- !TF +-- TIP (HCons (MyVal 20) (HCons 2 (HCons True (HCons 3.5 HNil)))) + + +-- Negate the boolean component of tip1 +-- tip3 = runIdentity $ ttipM (retI . not) tip1 -- !Simple +tip3 = runIdentity $ ttipM (return . not) tip1 -- !TF +-- TIP (HCons (MyVal 20) (HCons 1 (HCons False (HCons 3.5 HNil)))) + +-- Update the Int component from the values of two other components +tip4 = runIdentity $ ttipM (\(MyVal x) y -> retI $ x+y) tip1 +-- TIP (HCons (MyVal 20) (HCons 21 (HCons True (HCons 3.5 HNil)))) + +-- Update the MyVal component from the values of three other components +tip5 = runIdentity $ + ttipM (\b (MyVal x) y -> retI $ MyVal $ if b then x+y else 0) tip1 +-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil)))) + +-- The same but with the permuted argument order. +-- The order of arguments is immaterial: the values will be looked up using +-- their types +tip5' = runIdentity $ + ttipM (\b y (MyVal x)-> retI $ MyVal $ if b then x+y else 0) tip1 +-- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil)))) + +-- Andrew Frank's test +-- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil))))) +tip6 :: IO (TIP (TagR [MyVal,Int,Bool, Float])) +tip6 = ttipM op6 tip1 + +op6 :: MyVal -> Bool -> IO MyVal +op6 (MyVal x) b = do + let m = if b then MyVal (x `div` 4) else MyVal (x * 4) + putStrLn $ "MyVal is now " ++ show m + -- ==>> MyVal 5 + return m +-- TIP (HCons (MyVal 5) (HCons 1 (HCons True (HCons 3.5 HNil)))) + + +op6w :: MyVal -> Bool -> Writer String MyVal +op6w (MyVal x) b = do + let m = if b then MyVal (x `div` 4) else MyVal (x * 4) + tell ("MyVal is now " ++ show m) + -- ==>> MyVal 5 + return m + + +{- -- !Simple +-- The Simple implementation +-- The drawback is the need to let the type checker know the monad in which the +-- computations take place. That is why we had to use retI in the above +-- code, which is a specialized version of return for the Identity monad. +-- In op6, the presence of putStrLn unambiguously specified the monad, viz. IO, +-- so no special return are required. + +class Monad m => TransTIPM m op db where + ttipM :: op -> db -> m db + +-- If the operation is the computation in the desired monad, +-- the type of the computation must match an element of TIP. +instance (Monad m, + HTypeIndexed db, HUpdateAtHNat n op db db, HType2HNat op db n) + => TransTIPM m (m op) (TIP db) where + ttipM op db = do + op' <- op + return $ tipyUpdate op' db + +-- If op is not a computation in the desired monad m, +-- it must be a function. Look up its argument in a TIP and recur. +instance (Monad m, HOccurs arg db, TransTIPM m op db) + => TransTIPM m (arg -> op) db where + ttipM f db = ttipM (f (hOccurs db)) db +-} -- !Simple + +-- {- -- !TF +-- Moved to TIP.hs +-- -} -- !TF + +mainTTIPM = describe "ttipM" $ it "all" $ do + tip1 `shouldShowTo` "TIPH[MyVal 20,1,True,3.5]" + tip2 `shouldShowTo` "TIPH[MyVal 20,2,True,3.5]" + tip3 `shouldShowTo` "TIPH[MyVal 20,1,False,3.5]" + tip4 `shouldShowTo` "TIPH[MyVal 20,21,True,3.5]" + tip5 `shouldShowTo` "TIPH[MyVal 21,1,True,3.5]" + let tip6w = runWriter (ttipM op6w tip1) + fst tip6w `shouldShowTo` "TIPH[MyVal 5,1,True,3.5]" + snd tip6w `shouldBe` "MyVal is now MyVal 5" + diff --git a/examples/Joy.hs b/examples/Joy.hs deleted file mode 100644 --- a/examples/Joy.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# OPTIONS -fallow-overlapping-instances #-} -{-# OPTIONS -fallow-undecidable-instances #-} - ---Joy implemented in Haskell... extensible embedded language... - -module Joy where - -import MainGhcGeneric1 - --- Building non-empty lists - -type HOne = HSucc HZero -hOne :: HOne -hOne = undefined -type HTwo = HSucc HOne -hTwo :: HTwo -hTwo = undefined -type HThree = HSucc HTwo -hThree :: HThree -hThree = undefined - -end :: HNil -end = hNil - -instance HList s => Apply HNil s s where - apply _ s = s -instance (HList s,HList s',HList l,Apply a s s',Apply l s' s'') => Apply (HCons a l) s s'' where - apply (HCons a l) s = apply l (apply a s :: s') -instance HList s => Apply HZero s (HCons HZero s) where - apply _ s = hCons hZero s -instance (HNat a,HList s) => Apply (HSucc a) s (HCons (HSucc a) s) where - apply a s = hCons a s - -data Lit a = Lit a -lit :: a -> Lit a -lit a = Lit a -unl :: Lit a -> a -unl (Lit a) = a -instance Show a => Show (Lit a) where - showsPrec _ (Lit a) = showChar '[' . shows a . showChar ']' -instance HList s => Apply (Lit a) s (HCons a s) where - apply (Lit a) s = hCons a s - -class (HBool b,HList s) => HIfte b t f s s' | b t f s -> s' where - hIfte :: b -> t -> f -> s -> s' -instance (HList s,Apply t s s') => HIfte HTrue t f s s' where - hIfte _ t _ s = apply t s -instance (HList s,Apply f s s') => HIfte HFalse t f s s' where - hIfte _ _ f s = apply f s - -data Ifte -ifte :: Ifte -ifte = undefined -instance Show Ifte where - showsPrec _ _ = showString "If" -instance (Apply b s r,HHead r b',HIfte b' t f s s') - => Apply Ifte (f :*: t :*: b :*: s) s' where - apply _ (HCons f (HCons t (HCons b s))) = hIfte (hHead (apply b s :: r) :: b') t f s - -data Nul -nul :: Nul -nul = undefined -instance Show Nul where - showsPrec _ _ = showString "Nul" -instance HList s => Apply Nul (HCons HZero s) (HCons HTrue s) where - apply _ (HCons _ s) = hCons hTrue s -instance HList s => Apply Nul (HCons (HSucc n) s) (HCons HFalse s) where - apply _ (HCons _ s) = hCons hFalse s - -data EQ -eq :: EQ -eq = undefined -instance Show EQ where - showsPrec _ _ = showString "Eq" -instance (HList s,TypeEq a b t) => Apply EQ (HCons a (HCons b s)) (HCons t s) where - apply _ (HCons a (HCons b s)) = hCons (typeEq a b) s - -data Dip -dip :: Dip -dip = undefined -instance Show Dip where - showsPrec _ _ = showString "Dip" -instance (HList s,HList s',Apply a s s') => Apply Dip (HCons a (HCons b s)) (HCons b s') where - apply _ (HCons a (HCons b s)) = hCons b (apply a s) - -data Dup -dup :: Dup -dup = undefined -instance Show Dup where - showsPrec _ _ = showString "Dup" -instance HList s => Apply Dup (HCons a s) (HCons a (HCons a s)) where - apply _ s@(HCons a _) = hCons a s - -data Pop -pop :: Pop -pop = undefined -instance Show Pop where - showsPrec _ _ = showString "Pop" -instance HList s => Apply Pop (HCons a s) s where - apply _ (HCons _ s) = s - -data Swap -swap :: Swap -swap = undefined -instance Show Swap where - showsPrec _ _ = showString "Swap" -instance HList s => Apply Swap (HCons a (HCons b s)) (HCons b (HCons a s)) where - apply _ (HCons a (HCons b s)) = hCons b (hCons a s) - -data Suc -suc :: Suc -suc = undefined -instance Show Suc where - showsPrec _ _ = showString "Suc" -instance (HNat a,HList s) => Apply Suc (HCons a s) (HCons (HSucc a) s) where - apply _ (HCons _ s) = hCons (undefined::HSucc a) s - -data Pre -pre :: Pre -pre = undefined -instance Show Pre where - showsPrec _ _ = showString "Pre" -instance (HNat a,HList s) => Apply Pre (HCons (HSucc a) s) (HCons a s) where - apply _ (HCons _ s) = hCons (undefined::a) s - -data Add -add :: Add -add = undefined -instance Show Add where - showsPrec _ _ = showString "Add" -instance (HList s,HAdd a b c) => Apply Add (HCons a (HCons b s)) (HCons c s) where - apply _ (HCons _ (HCons _ s)) = hCons (hAdd (undefined::a) (undefined::b)) s - -class (HNat a,HNat b) => HAdd a b c | a b -> c where - hAdd :: a -> b -> c -instance HAdd HZero HZero HZero where - hAdd _ _ = hZero -instance HNat b => HAdd HZero (HSucc b) (HSucc b) where - hAdd _ b = b -instance HNat a => HAdd (HSucc a) HZero (HSucc a) where - hAdd a _ = a -instance (HNat (HSucc a),HNat (HSucc b),HNat c,HAdd a b c) - => HAdd (HSucc a) (HSucc b) (HSucc (HSucc c)) where - hAdd _ _ = hSucc $ hSucc $ hAdd (undefined::a) (undefined::b) - -data Sub -sub :: Sub -sub = undefined -instance Show Sub where - showsPrec _ _ = showString "Sub" -instance (HList s,HSub a b c) => Apply Sub (HCons b (HCons a s)) (HCons c s) where - apply _ (HCons _ (HCons _ s)) = hCons (hSub (undefined::a) (undefined::b)) s - -class (HNat a,HNat b) => HSub a b c | a b -> c where - hSub :: a -> b -> c -instance HSub HZero HZero HZero where - hSub _ _ = hZero -instance HNat a => HSub (HSucc a) HZero (HSucc a) where - hSub a _ = a -instance HNat a => HSub HZero (HSucc a) HZero where - hSub _ _ = hZero -instance (HSub a b c) => HSub (HSucc a) (HSucc b) c where - hSub _ _ = hSub (undefined::a) (undefined::b) - -data Mult -mult :: Mult -mult = undefined -instance Show Mult where - showsPrec _ _ = showString "Mult" -instance (HList s,HMult a b c) => Apply Mult (HCons a (HCons b s)) (HCons c s) where - apply _ (HCons _ (HCons _ s)) = hCons (hMult (undefined::a) (undefined::b)) s - -class (HNat a,HNat b) => HMult a b c | a b -> c where - hMult :: a -> b -> c -instance HNat b => HMult HZero b HZero where - hMult _ _ = hZero -instance (HMult a b s,HAdd b s s') => HMult (HSucc a) b s' where - hMult _ _ = hAdd (undefined::b) (hMult (undefined::a) (undefined::b) :: s) - -square = dup .*. mult .*. hNil -cube = mult .*. mult .*. dup .*. dup .*. hNil - -data I -i :: I -i = undefined -instance Show I where - showsPrec _ _ = showString "I" -instance Apply I HNil HNil where - apply _ _ = hNil -instance (HList s,Apply a s s') => Apply I (HCons a s) s' where - apply _ (HCons a s) = apply a s - -data Primrec = Primrec deriving Show -primrec :: Primrec -primrec = undefined -instance Apply z s s' => Apply Primrec (HCons nz (HCons z (HCons HZero s))) s' where - apply _ (HCons _ (HCons z (HCons _ s))) = apply z s -instance (HList s,Apply Primrec (HCons nz (HCons z (HCons n (HCons (HSucc n) s)))) s',Apply nz s' s'') - => Apply Primrec (HCons nz (HCons z (HCons (HSucc n) s))) s'' where - apply _ (HCons nz (HCons z s@(HCons _ _))) = apply nz (apply Primrec (hCons nz (hCons z (hCons (undefined::n) s)))) - -data Times -times :: Times -times = undefined -instance Show Times where - showsPrec _ _ = showString "Times" -instance HList s => Apply Times (HCons p (HCons HZero s)) s where - apply _ (HCons _ (HCons _ s)) = s -instance (HNat n,HList s,HList s',Apply p s s',Apply Times (HCons p (HCons n s')) s'') - => Apply Times (HCons p (HCons (HSucc n) s)) s'' where - apply _ (HCons p (HCons _ s)) = apply times (hCons p (hCons (undefined::n) (apply p s))) - -class (HBool f,HList s) => HGenrec f r1 r2 b t s s'' | f r1 r2 b t s -> s'' where - hGenrec :: f -> r1 -> r2 -> b -> t -> s -> s'' -instance (HList s,Apply t s s') => HGenrec HTrue r1 r2 b t s s' where - hGenrec _ _ _ _ t s = apply t s -instance (HList s,HList s',Apply r1 s s', - Apply (HCons (Lit (HCons (Lit b) (HCons (Lit t) (HCons (Lit r1) (HCons (Lit r2) (HCons Genrec HNil)))))) (HCons r2 HNil)) s' s'') - => HGenrec HFalse r1 r2 b t s s'' where - hGenrec _ r1 r2 b t s = apply (hCons (lit (hCons (lit b) (hCons (lit t) (hCons (lit r1) (hCons (lit r2) (hCons genrec hNil)))))) (hCons r2 hNil)) (apply r1 s :: s') - -data Genrec -genrec :: Genrec -genrec = undefined -instance Show Genrec where - showsPrec _ _ = showString "Genrec" -instance (Apply b s s',HHead s' b',HGenrec b' r1 r2 b t s s'') - => Apply Genrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where - apply _ (HCons r2 (HCons r1 (HCons t (HCons b s)))) - = hGenrec (hHead (apply b s :: s') :: b') r1 r2 b t s - -class (HBool f,HList s) => HLinrec f b t r1 r2 s s' | f b t r1 r2 s -> s' where - hLinrec :: f -> b -> t -> r1 -> r2 -> s -> s' -instance (HList s,Apply t s s') => HLinrec HTrue b t r1 r2 s s' where - hLinrec _ _ t _ _ s = apply t s -instance (HList s,HList s',Apply r1 s s', - Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s')))) s'',Apply r2 s'' s''') - => HLinrec HFalse b t r1 r2 s s''' where - hLinrec _ b t r1 r2 s = apply r2 (apply linrec (hCons r2 (hCons r1 (hCons t (hCons b (apply r1 s :: s'))))) :: s'') - -data Linrec -linrec :: Linrec -linrec = undefined -instance Show Linrec where - showsPrec _ _ = showString "Linrec" -instance (Apply b s s',HHead s' b',HLinrec b' b t r1 r2 s s'') => Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where - apply _ (HCons r2 (HCons r1 (HCons t (HCons b s)))) = hLinrec (hHead (apply b s :: s') :: b') b t r1 r2 s - -data Fact -fact :: Fact -fact = undefined -instance Show Fact where - showsPrec _ _ = showString "Fact" -instance (HList s,Apply (HCons (Lit (HCons (Lit HZero) (HCons EQ HNil))) - (HCons (Lit (HCons Pop (HCons (Lit HOne) HNil))) - (HCons (Lit (HCons Dup - (HCons (Lit HOne) - (HCons Sub (HCons Fact (HCons Mult HNil)))))) - (HCons Ifte HNil)))) s s') => Apply Fact s s' where - apply _ s = apply fac1 s - -fac1 = hCons (lit (hCons (lit hZero) (hCons eq hNil))) - (hCons (lit (hCons pop (hCons (lit hOne) hNil))) - (hCons (lit (hCons dup (hCons (lit hOne) (hCons sub (hCons fact (hCons mult hNil)))))) - (hCons ifte hNil))) - -fac2 = lit (hOne .*. hOne .*. end) - .*. dip .*. lit (dup .*. lit mult .*. dip .*. suc .*. end) - .*. times .*. pop .*. end - -fac3 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end) - .*. lit (i .*. mult .*. end) .*. genrec .*. end - -fac4 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end) - .*. lit mult .*. linrec .*. end - -fac5 = lit hOne .*. lit mult .*. primrec .*. end - -main :: IO () -main = do - putStrLn $ show $ apply (lit hThree .*. fac1 .*. end) end - putStrLn $ show $ apply i (fac2 .*. hThree .*. end) - putStrLn $ show $ apply i (fac3 .*. hThree .*. end) - putStrLn $ show $ apply i (fac4 .*. hThree .*. end) - putStrLn $ show $ apply i (fac5 .*. hThree .*. end) - diff --git a/examples/MainGhcGeneric1.hs b/examples/MainGhcGeneric1.hs deleted file mode 100644 --- a/examples/MainGhcGeneric1.hs +++ /dev/null @@ -1,341 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverlappingInstances#-} -{-# LANGUAGE UndecidableInstances#-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- - - (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke - - This is a main module for exercising a model with generic type - cast and generic type equality. Because of generic type equality, - this model works with GHC but it does not work with Hugs. - - Note: even though there are no overlapping instances in *this* - module, one must still enable overlapping instances here; otherwise - overlapping (for type equality) is not resolved properly for the - imported modules. - --} - -module MainGhcGeneric1 ( - -{- - module Datatypes2, - module Data.HList.CommonMain, - module Data.HList.TypeEqO, - module Data.HList.Label3, --- mainExport --} - -) where - -import Datatypes2 -import Data.HList.CommonMain -- hiding (HDeleteMany, hDeleteMany) - -{- -import Data.HList.RecordAdv -import Data.HList.RecordP --} - - --- -------------------------------------------------------------------------- - -type Animal = '[Key,Name,Breed,Price] - -angus :: HList Animal -angus = HCons (Key 42) - (HCons (Name "Angus") - (HCons Cow - (HCons (Price 75.5) - HNil))) - -tList1 = hFoldr (HSeq HPrint) (return () :: IO ()) angus -{- - Key 42 - Name "Angus" - Cow - Price 75.5 --} - -tList2 = print $ hAppend angus angus -{- -H[Key 42, Name "Angus", Cow, Price 75.5, Key 42, Name "Angus", Cow, Price 75.5] --} - - -testListBasic = do - putStrLn "\nBasic HList tests" - tList1 - tList2 - -testHArray = do - putStrLn "\ntestHArray" - myProj1 - myProj2 - myProj2' - myProj3 - myProj4 - -myProj1 = print $ hProjectByHNats (hNats (HCons hZero (HCons hZero HNil))) angus --- H[Key 42] - --- Before: --- H[Key 42, Key 42] --- XXX I don't duplicate at present! - -myProj2 = print $ - hProjectByHNats (hNats (HCons hZero (HCons (hSucc hZero) HNil))) angus --- H[Key 42, Name "Angus"] - -myProj2' = print $ - hProjectByHNats (undefined::Proxy ['HZero, 'HSucc 'HZero]) angus --- H[Key 42, Name "Angus"] - -myProj3 = print $ - hProjectAwayByHNats (hNats (HCons hZero HNil)) angus --- H[Name "Angus", Cow, Price 75.5] - -myProj4 = print $ - hSplitByHNats - (undefined::Proxy ['HZero, 'HSucc 'HZero]) - angus --- (H[Key 42, Name "Angus"],H[Cow, Price 75.5]) - -testHOccurs = do - putStrLn "\ntestHOccurs" - print (hOccurs angus :: Breed) - print $ hOccurs (TIP (HCons 1 HNil)) - print $ null $ hOccurs (TIP (HCons [] HNil)) - print (hProject angus :: HList '[Key, Name]) - - -testTypeIndexed = do - putStrLn "\ntestTypeIndexed" - print typeIdx1 - print typeIdx2 - print $ hUpdateAt Sheep typeIdx1 - print $ hDeleteAt (undefined::Proxy Breed) typeIdx2 - print $ hProjectBy (undefined::Proxy '[Breed]) angus - print $ hSplitBy (undefined:: Proxy '[Breed]) angus - where - typeIdx1 = hDeleteMany (undefined::Proxy Name) angus - typeIdx2 = BSE .*. angus - --- | --- This example from the TIR paper challenges singleton lists. --- Thanks to the HW 2004 reviewer who pointed out the value of this example. --- We note that the explicit type below is richer than the inferred type. --- This richer type is needed for making this operation more polymorphic. --- That is, /a)/ would not work without the explicit type, --- while /b/ would: --- --- > a) ((+) (1::Int)) $ snd $ tuple oneTrue --- > b) ((+) (1::Int)) $ fst $ tuple oneTrue - -tuple :: forall e1 e2 n l n2. - (HDeleteAtHNat n l, - HOccurs e1 (TIP l), - HOccurs e2 (TIP (HDeleteAtHNatR n l)), - HType2HNat e1 l n, - -- extra, not inferred - HType2HNat e2 l n2, - HOccurs e1 (TIP (HDeleteAtHNatR n2 l)) - ) => TIP l -> (e1,e2) -tuple (TIP l) = let - x = hOccurs (TIP l) - l' = hDeleteAt (undefined::Proxy e1) l - y = hOccurs (TIP l') - in (x,y) - --- | A specific tuple --- Need to import an instance of TypeEq to be able to run the examples -oneTrue :: TIP '[Int, Bool] -- inferred -oneTrue = (1::Int) .*. True .*. emptyTIP - -testTuple = do - putStrLn "\ntestTuple" - print $ let (a,b) = tuple oneTrue in (a+(1::Int), not b) - print $ let b = not $ fst $ tuple oneTrue in (1::Int,b) - print $ tuple oneTrue == (1::Int,True) - print $ ((+) (1::Int)) $ fst $ tuple oneTrue - -- requires explicit type for tuple - print $ ((+) (1::Int)) $ snd $ tuple oneTrue - - -myTipyCow = TIP angus - -animalKey :: ( SubType l (TIP Animal) -- explicit - , HOccurs Key l -- implicit - ) => l -> Key -animalKey = hOccurs - -animalish :: SubType l (TIP Animal) => l -> l -animalish = id -animalKey' l = hOccurs (animalish l) :: Key - -testTIP = do - putStrLn "\ntestTIP" - print $ (hOccurs myTipyCow :: Breed) - print $ BSE .*. myTipyCow - -- print $ hExtend Sheep $ myTipyCow - {- if we uncomment the line above, we get the type error - about the violation of the TIP condition: Breed type - occurs twice. - - No instance for (Fail * (TypeFound Breed)) - arising from a use of `hExtend' - -} - print $ Sheep .*. tipyDelete (undefined::Proxy Breed) myTipyCow - print $ tipyUpdate Sheep myTipyCow - -{- -data MyNS = MyNS -- a name space for record labels - -key = firstLabel MyNS (undefined::DKey) -name = nextLabel key (undefined::DName) -breed = nextLabel name (undefined::DBreed) -price = nextLabel breed (undefined::DPrice) - -data DKey; instance Show DKey where show _ = "key" -data DName; instance Show DName where show _ = "name" -data DBreed; instance Show DBreed where show _ = "breed" -data DPrice; instance Show DPrice where show _ = "price" - --} - -makeLabels3 "MyNS" (words "key name breed price") - -unpricedAngus = key .=. (42::Integer) - .*. name .=. "Angus" - .*. breed .=. Cow - .*. emptyRecord - - -getKey l = hLookupByLabel key l - -testRecords = do - putStrLn "\ntestRecords" - print $ unpricedAngus - print $ unpricedAngus .!. breed - print $ test3 - print $ test4 - print $ test5 - print $ hProjectByLabels (hLabels (breed `HCons` price `HCons` HNil)) test5 - where - test3 = hDeleteAtLabel breed unpricedAngus - test4 = breed .=. Sheep .@. unpricedAngus - test5 = price .=. 8.8 .*. unpricedAngus - -- test7 should have the same type as unpricedAngus and test4 but - -- with the different order of labels - test7 = (newLVPair breed Sheep) .*. test3 - -{- -testRecords = ( test1 - , ( test2 - , ( test3 - , ( test4 - , ( test5 - , ( test6 - , (test7, test81, test82, test83, test84, test85) - )))))) - where - test81 = equivR test1 test3 -- HNothing - test82 = let HJust (r17,r71) = equivR test1 test7 in (r17 test1,r71 test7) - test83 = let HJust (r17,r71) = - equivR test1 test7 in show (r17 test1) == show test7 - test84 = let HJust (r47,r74) = - equivR test4 test7 in (show (r47 test4) == show test7, - show (r74 test7) == show test4) - test85 = let HJust (r7,r7') = - equivR test7 test7 in show (r7 test7) == show (r7' test7) - -testRecordsP = ( test1 - , ( test2 - , ( test3 - , ( test4 - , ( test5 - , ( test6 - )))))) - where --- test1 = mkRecordP (undefined::Animal) angus - test1 = record_r2p unpricedAngus - test2 = test1 .!. breed - test3 = hDeleteAtLabelP breed test1 --- test4 = test1 .@. breed .=. Sheep - test4 = hExtend (newLVPair breed Sheep) test3 - test5 = price .=. 8.8 .*. test1 - test6 = fst $ h2projectByLabels (HCons breed (HCons price HNil)) test5 - - --} - -type AnimalCol = [Key,Name,Breed,Price] - -testTIC = do - putStrLn "\ntestTIC" - print $ myCol - print $ (unTIC myCol :: Maybe Breed) - print $ (unTIC myCol :: Maybe Price) - where - myCol = mkTIC Cow :: TIC AnimalCol - -{- - -myCol = mkTIC Cow :: TIC AnimalCol - -*TIC> unTIC myCol :: Maybe Breed -Just Cow -*TIC> unTIC myCol :: Maybe Price -Nothing -*TIC> mkTIC "42" :: TIC AnimalCol -Type error ... -*TIC> unTIC myCol :: Maybe String -Type error ... - --} - -testVariant = (testVar1,(testVar2,(testVar3))) - where - animalVar = key .=. (Proxy::Proxy Integer) - .*. name .=. (Proxy::Proxy String) - .*. breed .=. (Proxy::Proxy Breed) - .*. emptyRecord - testVar1 = mkVariant name "angus" animalVar - testVar2 = unVariant key testVar1 - testVar3 = unVariant name testVar1 - -{- --- -------------------------------------------------------------------------- - -main = mainExport -mainExport - = print $ ( testHArray - , ( testHOccurs - , ( testTypeIndexed - , ( testTuple - , ( testTIP - - , ( testRecords - , ( testRecordsP - , ( testTIC - , ( testVariant - ))))))))) - --} - -main = do - testListBasic - testHArray - testHOccurs - testTypeIndexed - testTuple - testTIP - testRecords - testTIC diff --git a/examples/MainGhcGeneric1.out b/examples/MainGhcGeneric1.out deleted file mode 100644 --- a/examples/MainGhcGeneric1.out +++ /dev/null @@ -1,54 +0,0 @@ - -Basic HList tests -Key 42 -Name "Angus" -Cow -Price 75.5 -H[Key 42, Name "Angus", Cow, Price 75.5, Key 42, Name "Angus", Cow, Price 75.5] - -testHArray -H[Key 42] -H[Key 42, Name "Angus"] -H[Key 42, Name "Angus"] -H[Name "Angus", Cow, Price 75.5] -(H[Key 42, Name "Angus"],H[Cow, Price 75.5]) - -testHOccurs -Cow -1 -True -H[Key 42, Name "Angus"] - -testTypeIndexed -H[Key 42, Cow, Price 75.5] -H[BSE, Key 42, Name "Angus", Cow, Price 75.5] -H[Key 42, Sheep, Price 75.5] -H[BSE, Key 42, Name "Angus", Price 75.5] -H[Cow] -(H[Cow],H[Key 42, Name "Angus", Price 75.5]) - -testTuple -(2,False) -(1,False) -True -2 -2 - -testTIP -Cow -TIPH[BSE, Key 42, Name "Angus", Cow, Price 75.5] -TIPH[Sheep, Key 42, Name "Angus", Price 75.5] -TIPH[Key 42, Name "Angus", Sheep, Price 75.5] - -testRecords -Record{key=42,name="Angus",breed=Cow} -Cow -Record{key=42,name="Angus"} -Record{key=42,name="Angus",breed=Sheep} -Record{price=8.8,key=42,name="Angus",breed=Cow} -Record{price=8.8,breed=Cow} - -testTIC - -Just Cow -Nothing diff --git a/examples/MainGhcGeneric1.ref b/examples/MainGhcGeneric1.ref deleted file mode 100644 --- a/examples/MainGhcGeneric1.ref +++ /dev/null @@ -1,54 +0,0 @@ - -Basic HList tests -Key 42 -Name "Angus" -Cow -Price 75.5 -H[Key 42, Name "Angus", Cow, Price 75.5, Key 42, Name "Angus", Cow, Price 75.5] - -testHArray -H[Key 42] -H[Key 42, Name "Angus"] -H[Key 42, Name "Angus"] -H[Name "Angus", Cow, Price 75.5] -(H[Key 42, Name "Angus"],H[Cow, Price 75.5]) - -testHOccurs -Cow -1 -True -H[Key 42, Name "Angus"] - -testTypeIndexed -H[Key 42, Cow, Price 75.5] -H[BSE, Key 42, Name "Angus", Cow, Price 75.5] -H[Key 42, Sheep, Price 75.5] -H[BSE, Key 42, Name "Angus", Price 75.5] -H[Cow] -(H[Cow],H[Key 42, Name "Angus", Price 75.5]) - -testTuple -(2,False) -(1,False) -True -2 -2 - -testTIP -Cow -TIPH[BSE, Key 42, Name "Angus", Cow, Price 75.5] -TIPH[Sheep, Key 42, Name "Angus", Price 75.5] -TIPH[Key 42, Name "Angus", Sheep, Price 75.5] - -testRecords -Record{key=42,name="Angus",breed=Cow} -Cow -Record{key=42,name="Angus"} -Record{key=42,name="Angus",breed=Sheep} -Record{price=8.8,key=42,name="Angus",breed=Cow} -Record{price=8.8,breed=Cow} - -testTIC - -Just Cow -Nothing diff --git a/examples/MainGhcGeneric2.hs b/examples/MainGhcGeneric2.hs deleted file mode 100644 --- a/examples/MainGhcGeneric2.hs +++ /dev/null @@ -1,22 +0,0 @@ -{- - - (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke - - Included for completeness' sake. - The TypeEqBoolGeneric2.hs implementation is demonstrated. - --} - -module MainGhcGeneric2 where - -import Data.HList - - -{-----------------------------------------------------------------------------} - -main = print ( hEq True False - , hEq True "True" - ) - - -{-----------------------------------------------------------------------------} diff --git a/examples/MainGhcGeneric2.out b/examples/MainGhcGeneric2.out deleted file mode 100644 --- a/examples/MainGhcGeneric2.out +++ /dev/null @@ -1,1 +0,0 @@ -(HTrue,HFalse) diff --git a/examples/MainGhcGeneric2.ref b/examples/MainGhcGeneric2.ref deleted file mode 100644 --- a/examples/MainGhcGeneric2.ref +++ /dev/null @@ -1,1 +0,0 @@ -(HTrue,HFalse) diff --git a/examples/MainPatternMatch.hs b/examples/MainPatternMatch.hs deleted file mode 100644 --- a/examples/MainPatternMatch.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE PatternGuards #-} - --- Pattern-matching on HList's Records - -{- - See the thread `Re: (small) records proposal for Haskell '06' - Haskell mailing list, January 2006 - http://www.haskell.org/pipermail/haskell/2006-January/017276.html - -Joel Reymont wrote: -> How does pattern matching work with HList? -> I would like to pass a HList to a function and only match if a -> certain field had a certain value. - -The code below defines the function foo that accepts a record and -yields one value if the field PtX of the record has the value 0. If -the field has any other value, a different result is returned. The -function is written in a pattern-matching style. Also, the function is -record-polymorphic: it takes _any_ record (of any `record type') that -happens to have the field names PtX. - - *Test> :t foo - foo :: (Num v, HasField (Proxy PtX) r v) => r -> [Char] - --} - -module Main where - -import Data.HList - -makeLabels ["px","py"] - --- Labels --- The more convenient labels, Label4.hs, need -fallow-overlapping-instances --- The less convenient label representation needs fewer extensions. --- We go for more convenient... - -{- -data PtX; px = proxy::Proxy PtX -data PtY; py = proxy::Proxy PtY --} - - -accessor r f = r # f - --- 1D points -point1 x = - px .=. x - .*. emptyRecord - --- 2D points -point2 x y = - px .=. x - .*. py .=. (y + 10) - .*. emptyRecord - - --- Record-polymorphic function, which illustrates record pattern-matching, --- with the help of generalized guards -foo p | 0 <- p # px = "X is zero" -foo _ = "something else" - -test1 = foo (point1 0) -- X is zero -test1' = foo (point1 42) -- something else -test2 = foo (point2 10 20) -- something else --- inline construction of the record -test3 = foo (py .=. False .*. px .=. 0 .*. emptyRecord) -- X is zero - -main = do - putStrLn test1 - putStrLn test1' - putStrLn test2 - putStrLn test3 diff --git a/examples/MainPatternMatch.out b/examples/MainPatternMatch.out deleted file mode 100644 --- a/examples/MainPatternMatch.out +++ /dev/null @@ -1,4 +0,0 @@ -X is zero -something else -something else -X is zero diff --git a/examples/MainPatternMatch.ref b/examples/MainPatternMatch.ref deleted file mode 100644 --- a/examples/MainPatternMatch.ref +++ /dev/null @@ -1,4 +0,0 @@ -X is zero -something else -something else -X is zero diff --git a/examples/MainPosting-040607.hs b/examples/MainPosting-040607.hs deleted file mode 100644 --- a/examples/MainPosting-040607.hs +++ /dev/null @@ -1,302 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} - -{- - -Hi Mike, - -You might find heterogeneous lists useful. -http://www.cwi.nl/~ralf/HList/ -See the treatment of your example below. - -Cheers, -Ralf - --} - -module Main where - -import Data.HList - --- These are your two "implementations". - -data MyImplementation1 = MyImplementation1 Int deriving (Show,Eq,Typeable) -data MyImplementation2 = MyImplementation2 Int deriving (Show,Eq,Typeable) - - --- This is your interface class and the two instances. - -class MyInterface a - where - foo :: a -> Int - -instance MyInterface MyImplementation1 - where - foo (MyImplementation1 i) = i - -instance MyInterface MyImplementation2 - where - foo (MyImplementation2 i) = i - - --- Here is your list, --- without the noise you don't like. - -list1 = MyImplementation1 10 - .*. MyImplementation2 20 - .*. HNil - - --- If you like, this is the type, but it is not needed. --- This list is not opaque. Less trouble in our experience. --- (When compared to using existentials.) - -type MyList = HList '[MyImplementation1, MyImplementation2] - - --- Perhaps you want to make sure that you have a list of implementations --- of MyInterface. Here is *one* way to do it. But you don't need to do it --- because this will be automatically checked (statically) whenever you --- try to use the fooISH interface. - -class ListOfMyInterface l - where - listOfMyInterface :: HList l -> HList l - listOfMyInterface = id - -instance ListOfMyInterface '[] -instance ( MyInterface e - , ListOfMyInterface l - ) - => ListOfMyInterface (e ': l) - - --- So you apply the id function with the side effect of statically --- ensuring that you are given a list of implementations of MyInterface. - -list2 :: MyList -list2 = listOfMyInterface list1 - - --- Here is another way to do it. --- You apply a heterogenous fold to the list. --- This second solution is just for fun. - -data ImplementsMyInterface = ImplementsMyInterface - -instance ( - x ~ (e,HList l), - y ~ (HList (e ': l)) - ) => ApplyAB ImplementsMyInterface x y - where - applyAB _ (e,l) = HCons e l - -myKindOfList l = hFoldr ImplementsMyInterface HNil l - - --- Basically again you apply the identity function; a deep one this time. - -list3 :: MyList -list3 = myKindOfList list1 - - --- Your equality can indeed not work because the existentially quantified --- implementations are of course opaque. You cannot compare apples and --- oranges. Equality of heterogeneous lists is trivial; it is just derived. --- To make it a little bit more interesting, we can consider heterogeneous --- or stanamic equality. So you will always get a Boolean even for lists --- of different types. See below. - - --- Here is your bar function. --- It uses one sort of maps on heterogeneous lists. - -bar :: MyList -> Int -bar = sum . hMapOut Foo - -data Foo = Foo -- type driver for class-level application - -instance (MyInterface e, int ~ Int) => ApplyAB Foo e int - where - applyAB _ e = foo e - - --- Yet another heterogeneous equality. --- Just for fun. --- -yaHEq :: (Typeable a, Typeable b, Eq a) => a -> b -> Bool -yaHEq a b = case cast b of - Just a' -> a == a' - Nothing -> False - --- Yet another heterogeneous list; a bit less typed. -data AnyMyInterface = forall a. ( Eq a - , Typeable a - , MyInterface a - ) => AnyMyInterface a - -type MyList' = [AnyMyInterface] -list4 = [ AnyMyInterface $ MyImplementation1 10 - , AnyMyInterface $ MyImplementation1 10 - ] -list5 = [ AnyMyInterface $ MyImplementation1 10 - , AnyMyInterface $ MyImplementation2 10 - ] -list6 = [ AnyMyInterface $ MyImplementation1 10 - , AnyMyInterface $ MyImplementation2 20 - ] - -instance Eq AnyMyInterface - where - (AnyMyInterface x) == (AnyMyInterface y) = x `yaHEq` y - - -{- - -Demo follows. - -*Main> :l gh-users-040607.hs -Compiling FakePrelude ( ./FakePrelude.hs, interpreted ) -Compiling HType ( HType.hs, interpreted ) -Compiling HList ( ./HList.hs, interpreted ) -Compiling HArray ( ./HArray.hs, interpreted ) -Compiling HTypeDriven ( ./HTypeDriven.hs, interpreted ) -Compiling Main ( gh-users-040607.hs, interpreted ) -Ok, modules loaded: Main, HTypeDriven, HArray, HList, HType, FakePrelude. -*Main> list1 -HCons (MyImplementation1 10) (HCons (MyImplementation2 20) HNil) -*Main> bar list1 -30 -*Main> list1 == list1 -True -*Main> list1 `hStagedEq` hReverse list1 -False -*Main> list4!!0 == list4!!1 -True -*Main> list5!!0 == list5!!1 -False -*Main> list6!!0 == list6!!1 -False - --} - -main = print - ( list1 - , ( list1 == list1 - -- , ( list1 `hStagedEq` hReverse list1 - , ( list4!!0 == list4!!1 - , ( list5!!0 == list5!!1 - , ( list6!!0 == list6!!1 - ))))) - -{- - -Mike Aizatsky wrote: - ->Hello, -> ->I'm in process of rewriting the old Java application. While this is for sure ->lots of fun, there're some problems in modeling the java interfaces. -> ->Here's the common Java scenario (it's actually the pattern, common for all ->OO-languages, so there should be no problems in understanding it): -> ->interface MyInterface { -> int foo(); ->} -> ->class MyImplementation1 implements MyInterface { int foo() {...} } ->class MyImplementation2 implements MyInterface { int foo() {...} } -> ->And, somewhere in the code: -> ->int bar(List list) { .... sum up all foos & return .... } -> ->I've found quite an obvious translation of it to Haskell: -> ->module Ex where -> ->class MyInterface a where -> foo :: a -> Int -> ->data AnyMyInterface = forall a. (MyInterface a) => AnyMyInterface a -> ->instance MyInterface AnyMyInterface where -> foo (AnyMyInterface a) = foo a -> -> ->data MyImplementation1 = MyImplementation1 Int -> ->instance MyInterface MyImplementation1 where -> foo(MyImplementation1 i) = i -> ->data MyImplementation2 = MyImplementation2 Int -> ->instance MyInterface MyImplementation2 where -> foo(MyImplementation2 i) = i -> -> ->type MyList = [AnyMyInterface] -> ->list1 :: MyList ->list1 = [AnyMyInterface (MyImplementation1 10), AnyMyInterface ->(MyImplementation2 20)] -> ->bar :: MyList -> Int ->bar l = sum (map foo l) -> -> ->However there're some problems with this way to go: -> ->1. It's quite verbose. I already have a dozen of such interfaces, and I'm a ->bit tired of writing all this AnyInterface stuff. I'm already thinking about ->writing the Template Haskell code to generate it. Is anything similar ->available around? -> ->2. I don't like the fact that I need to wrap all implementations inside the ->AnyMyInterface when returning values (see list1). Any way to get rid of it? -> ->3. The big problem. I can't make AnyMyInterface to be an instance of Eq. I ->write: -> ->data AnyMyInterface = forall a. (MyInterface a, Eq a) => AnyMyInterface a ->instance Eq AnyMyInterface where -> (==) (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2 -> ->And it gives me an error (ghc 6.2.1): -> -> Inferred type is less polymorphic than expected -> Quantified type variable `a1' is unified with another quantified ->type variable `a' -> When checking an existential match that binds -> a1 :: a -> a2 :: a1 -> The pattern(s) have type(s): AnyMyInterface -> AnyMyInterface -> The body has type: Bool -> In the definition of `==': -> == (AnyMyInterface a1) (AnyMyInterface a2) = a1 == a2 -> In the definition for method `==' -> ->Honestly, I don't understand what's going on. My guess is that the problem ->comes from the fact that a1 & a2 might be of different Implementations. Is ->it right? Any way to define the Eq instance of AnyMyInterface? -> -> ->So, it looks like that existential data types do allow you to mimic the ->polymorphic data structures, found in OO languages. But it results in much ->more verbose code. Are there any other ways to do the same stuff? -> ->_______________________________________________ ->Glasgow-haskell-users mailing list ->Glasgow-haskell-users@haskell.org ->http://www.haskell.org/mailman/listinfo/glasgow-haskell-users -> - --} diff --git a/examples/MainPosting-040607.out b/examples/MainPosting-040607.out deleted file mode 100644 --- a/examples/MainPosting-040607.out +++ /dev/null @@ -1,1 +0,0 @@ -(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False)))) diff --git a/examples/MainPosting-040607.ref b/examples/MainPosting-040607.ref deleted file mode 100644 --- a/examples/MainPosting-040607.ref +++ /dev/null @@ -1,1 +0,0 @@ -(H[MyImplementation1 10, MyImplementation2 20],(True,(True,(False,False)))) diff --git a/examples/MainPosting-051106.hs b/examples/MainPosting-051106.hs deleted file mode 100644 --- a/examples/MainPosting-051106.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Main where - --- Needed for a reply to the Haskell mailing list - -import Data.HList.CommonMain hiding (Comp(..)) - -main = do - print $ comp "abc" - print $ (hComposeList test2 "abc" :: Int) -- definition in HList now - -test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) HNil)) -test2 = length .*. (+1) .*. (*2) .*. HNil - -data Comp - -{- simpler class. wouldn't work with test2. The original HFoldr won't work with - - Apply anymore. -instance Apply Comp (x -> y,y -> z) - where - type ApplyR Comp (x -> y,y -> z) = x -> z - apply _ (f,g) = g . f - -} - -instance ((x -> y,y -> z) ~ xyz, (x -> z) ~ xz) - => ApplyAB Comp xyz xz - where - applyAB _ (f,g) = g . f - --- Function composition based on type code works. - -comp = hFoldr (undefined::Comp) (id::Int -> Int) test - --- Function composition based on normal polymorphism doesn't --- comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test - -{- - -From Ralf.Lammel at microsoft.com Mon Nov 7 00:11:01 2005 -From: Ralf.Lammel at microsoft.com (Ralf Lammel) -Date: Sun Nov 6 23:50:27 2005 -Subject: [Haskell-cafe] Type classes and hFoldr from HList -Message-ID: <1152E22EE8996742A7E36BBBA7768FEE079C474F@RED-MSG-50.redmond.corp.microsoft.com> - -Hi Greg, - -Since hfoldr is right-associative, I prefer to reorder your list of -functions as follows: - -> test = HCons (length::String -> Int) (HCons ((+1)::(Int->Int)) (HCons -((*2)::(Int->Int)) HNil)) - -Note that I also annotated length with its specific type. -(If you really wanted to leave things more polymorphic, you would need -to engage in TypeCast.) - -Providing a specific Apply instance for (.) is not necessary, strictly -necessary. We could try to exploit the normal function instance for -Apply. - -Let me recall that one here for convenience: - ->instance Apply (x -> y) x y -> where -> apply f x = f x - -Let me also recall the hFoldr instances: - ->class HList l => HFoldr f v l r | f v l -> r -> where -> hFoldr :: f -> v -> l -> r - ->instance HFoldr f v HNil v -> where -> hFoldr _ v _ = v - ->instance ( HFoldr f v l r -> , Apply f (e,r) r' -> ) -> => HFoldr f v (HCons e l) r' -> where -> hFoldr f v (HCons e l) = apply f (e,hFoldr f v l) - - -To fit in (.), we would flip and uncurry it. -So we could try: - -comp' = hFoldr (uncurry (flip (.))) (id::Int -> Int) test - -This wouldn't work. -The trouble is the required polymorphism of the first argument of -hFoldr. -The type of that argument as such is polymorphic. -However, this polymorphism does not survive type class parameterization. -You see this by looking at the HCons instance of HFoldr. -The different occurrences of "f" would need to be used at different -types. -This would only work if the type class parameter f were instantiated by -the polymorphic type of (uncurry (flip (.))). (And even then we may need -something like TypeCast.) - -What you can do is define a dedicated *type code* for composition. - -comp = hFoldr (undefined::Comp) (id::Int -> Int) test - -data Comp - -instance Apply Comp (x -> y,y -> z) (x -> z) - where - apply _ (f,g) = g . f - - -Ralf - - -> -----Original Message----- -> From: haskell-cafe-bounces@haskell.org [mailto:haskell-cafe- -> bounces@haskell.org] On Behalf Of Greg Buchholz -> Sent: Sunday, November 06, 2005 7:01 PM -> To: haskell-cafe@haskell.org -> Subject: [Haskell-cafe] Type classes and hFoldr from HList -> -> -> I was playing around with the HList library from the paper... -> -> Strongly typed heterogeneous collections -> http://homepages.cwi.nl/~ralf/HList/ -> -> ...and I thought I'd try to fold the composition function (.) through -a -> heterogeneous list of functions, using hFoldr... -> -> >{-# OPTIONS -fglasgow-exts #-} -> >{-# OPTIONS -fallow-undecidable-instances #-} -> > -> >import CommonMain -> > -> >main = print $ comp "abc" -> > -> >test = HCons ((+1)::(Int->Int)) (HCons ((*2)::(Int->Int)) (HCons -length -> HNil)) -> > -> >comp = hFoldr (.) id test -> > -> >instance Apply (a -> b -> c -> d) (a, b) (c -> d) -> > where -> > apply f (a,b) = f a b -> -> ...but it fails with the following type error... -> -> ]Compiling Main ( compose.hs, interpreted ) -> ] -> ]compose.hs:10:7: -> ] No instances for (Apply ((b -> c) -> (a -> b) -> a -> c) -> ] (Int -> Int, r) -> ] ([Char] -> a3), -> ] Apply ((b -> c) -> (a -> b) -> a -> c) (Int -> -Int, -> r1) r, -> ] Apply ((b -> c) -> (a -> b) -> a -> c) ([a2] -> -> Int, a1 ->a1) r1) -> ] arising from use of `hFoldr' at compose.hs:10:7-12 -> ] Probable fix: -> ] add an instance declaration for (Apply ((b -> c) -> (a -> b) -> -a - -> > c) -> ] (Int -> Int, r) -> ] ([Char] -> a3), -> ] Apply ((b -> c) -> (a -> b) -> -a - -> > c) -> ](Int -> Int, r1) r, -> ] Apply ((b -> c) -> (a -> b) -> -a - -> > c) -> ]([a2] -> Int, a1 -> a1) r1) -> ] In the definition of `comp': comp = hFoldr (.) id test -> -> ...Anyway, I couldn't quite tell whether I was using hFoldr -incorrectly, -> or if I needed to have more constraints placed on the construction of -> "test", or if needed some sort of type-level function that resolves... -> -> Apply ((b -> c) -> (a -> b) -> a -> c) -> -> ...into (a -> c), or something else altogether. I figured someone -might -> be able to help point me in the right direction. - --} diff --git a/examples/MainPosting-051106.out b/examples/MainPosting-051106.out deleted file mode 100644 --- a/examples/MainPosting-051106.out +++ /dev/null @@ -1,2 +0,0 @@ -8 -8 diff --git a/examples/MainPosting-051106.ref b/examples/MainPosting-051106.ref deleted file mode 100644 --- a/examples/MainPosting-051106.ref +++ /dev/null @@ -1,2 +0,0 @@ -8 -8 diff --git a/examples/Properties.hs b/examples/Properties.hs new file mode 100644 --- /dev/null +++ b/examples/Properties.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ > 906 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else +{-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- ghc-7.8 has no Typeable (x :: Symbol), so use OldTypeable +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | Description: quickcheck tests +-- +-- Many of the tests here use quickcheck. The lengths of the hlists +-- involved exhaustively cover a small range, while the elements +-- are random samples. +module Main where + +import Test.Hspec + +import Properties.LengthDependentSplice +import Properties.LengthIndependent +import Properties.KW + +main = hspec $ do + hl0 + hl1_2_3 + kwSpecs diff --git a/examples/Properties/Common.hs b/examples/Properties/Common.hs new file mode 100644 --- /dev/null +++ b/examples/Properties/Common.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +module Properties.Common where + +import Data.HList.CommonMain +import Test.QuickCheck +import Data.Array.Unboxed +import Data.HList.Variant +import Data.Monoid +import Data.Semigroup +import Control.Lens +import Control.Applicative +import GHC.TypeLits (Symbol) +import Language.Haskell.TH + +#if MIN_VERSION_hspec_expectations(0,8,0) +import Test.Hspec.Expectations (shouldBe, shouldReturn, Expectation, HasCallStack) +#else +import Test.Hspec.Expectations (shouldBe, shouldReturn, Expectation) +import GHC.Exts (Constraint) +type HasCallStack = (() :: Constraint) +#endif + +hListT :: [TypeQ] -> TypeQ +hListT = foldr (\a b -> [t| $a ': $b |]) promotedNilT + +hListE :: [ExpQ] -> ExpQ +hListE = foldr (\a b -> [| $a `HCons` $b |]) [| HNil |] + +hNatE :: Int -> ExpQ +hNatE n = foldr appE [| hZero |] (replicate n [| hSucc |]) + +hNatT :: Int -> TypeQ +hNatT n = foldr appT [t| HZero |] (replicate n [t| HSucc |]) + + +lx = Label :: Label "x" +ly = Label :: Label "y" +lz = Label :: Label "z" + +data BinF b = BinF (b -> b -> b) + +instance (bb ~ (b, b), b ~ b') => ApplyAB (BinF b') bb b where + applyAB (BinF f) = uncurry f + + +-- | A more general type than @===@ used to +-- ensure that both sides can infer the same type +eq :: (Show a, Show b, HCast a b, HCast b a, Eq a, Eq b) => a -> b -> Property +eq x y = hCast x === Just y .&&. Just x === hCast y +infix 4 `eq` + + +shouldShowTo :: (HasCallStack, Show a) => a -> String -> Expectation +shouldShowTo x y = show x `shouldBe` y +infixr 0 `shouldShowTo` + +shouldReturnShowTo :: (HasCallStack, Show a) => IO a -> String -> Expectation +shouldReturnShowTo x y = fmap show x `shouldReturn` y +infixr 0 `shouldReturnShowTo` + +data HSuccF = HSuccF + +instance (psn ~ Proxy (HSucc n), + pn ~ Proxy n) => ApplyAB HSuccF pn psn where + applyAB _ = hSucc + + +data HSplitAtAppend l = HSplitAtAppend (HList l) +instance (pn ~ Proxy n, + HSplitAt n l a b, + HAppend (HList a) (HList b), + y ~ HAppendR (HList a) (HList b)) => ApplyAB (HSplitAtAppend l) pn y where + applyAB (HSplitAtAppend l) n = case hSplitAt n l of + (a,b) -> hAppend a b + + + +data ConstTrue +instance HEqByFn ConstTrue +instance HEqBy ConstTrue x y True + +data ConstFalse +instance HEqByFn ConstFalse +instance HEqBy ConstFalse x y False + + +instance Arbitrary a => Arbitrary (Tagged t a) where + arbitrary = fmap Tagged arbitrary + +instance Arbitrary (HList '[]) where + arbitrary = return HNil + +instance (Arbitrary x, Arbitrary (HList xs)) => Arbitrary (HList (x ': xs)) where + arbitrary = do + x <- arbitrary + xs <- arbitrary + return $ x `HCons` xs + +instance (Arbitrary x, Arbitrary (Variant (Tagged t y ': ys)), + HExtend (Tagged s (Maybe x)) (Variant (Tagged t y ': ys)), + HNat2Integral (HLength ys)) + => Arbitrary (Variant (Tagged s x ': Tagged t y ': ys)) where + arbitrary = do + let nys = hNat2Integral (Proxy :: Proxy (HLength ys)) + x :: Maybe x <- frequency [ (1, Just <$> arbitrary), (nys+1, return Nothing) ] + yys :: Variant (Tagged t y ': ys) <- arbitrary + return $ Tagged x .*. yys + +instance Arbitrary z => Arbitrary (Variant '[Tagged t z]) where + arbitrary = do + z <- arbitrary + return $ mkVariant1 Label z + +instance (CoArbitrary x, CoArbitrary (Variant (y ': z)), + HNat2Integral n, n ~ HLength (y ': z)) => CoArbitrary (Variant (x ': y ': z)) where + coarbitrary v = case splitVariant1' v of + Left x -> variant (hNat2Integral (Proxy :: Proxy n) :: Int) . coarbitrary x + Right v' -> coarbitrary v' + +instance (CoArbitrary v, Unvariant '[Tagged t v] v) => CoArbitrary (Variant '[Tagged t v]) where + coarbitrary v = coarbitrary (unvariant v) + +-- | This type is used to make unique types with two members. +-- +-- > (BoolN True :: BoolN "x") /= (BoolN True :: BoolN "y") +-- +-- is a type error +newtype BoolN (n :: Symbol) = BoolN Bool + deriving (Eq,CoArbitrary,Arbitrary,Show,Read,Ord) + +boolN next = simple $ iso (\(BoolN x) -> x) BoolN next + +instance Monoid (BoolN n) where + mempty = BoolN (getAll mempty) +#if __GLASGOW_HASKELL__ <= 906 + mappend (BoolN x) (BoolN y) = BoolN (getAll (mappend (All x) (All y))) + +instance Semigroup (BoolN n) where (<>) = mappend +#else + +instance Semigroup (BoolN n) where + (BoolN x) <> (BoolN y) = BoolN (getAll (mappend (All x) (All y))) +#endif + +#if !MIN_VERSION_QuickCheck(2,9,0) +instance Arbitrary (Identity (BoolN n)) where + arbitrary = fmap return arbitrary +#endif + + +data HSortF = HSortF +instance (x ~ Record xs, + y ~ Record ys, + HRLabelSet ys, + HSort xs ys) => ApplyAB HSortF x y where + applyAB _ (Record x) = mkRecord (hSort x) diff --git a/examples/Properties/KW.hs b/examples/Properties/KW.hs new file mode 100644 --- /dev/null +++ b/examples/Properties/KW.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +module Properties.KW where + + +import Properties.Common +import Test.QuickCheck +import Data.HList.CommonMain +import Test.Hspec + + +kwSpecs = describe "kw" $ do + {- with NoMonoLocalBinds + - /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:59:15: error:ghc: panic! (the 'impossible' happened) + (GHC version 8.0.2 for x86_64-unknown-linux): + No skolem info: k_aqoh[sk] + + with MonoLocalBinds, I think the error is the same as in earlier versions + + /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:62:15: error: + • Couldn't match type ‘'[Tagged "x" (BoolN "x")]’ with ‘'[]’ + Expected type: Record '[] + Actual type: HExtendR (Tagged "x" (BoolN "x")) (Record '[]) + • In the first argument of ‘f2’, namely + ‘(lx .=. x2 .*. emptyRecord)’ + In the first argument of ‘eq’, namely + ‘f2 (lx .=. x2 .*. emptyRecord)’ + In the expression: f2 (lx .=. x2 .*. emptyRecord) `eq` f1 x2 y + + /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:63:15: error: + • Couldn't match type ‘'[Tagged "y" (BoolN "y")]’ with ‘'[]’ + Expected type: Record '[] + Actual type: HExtendR (Tagged "y" (BoolN "y")) (Record '[]) + • In the first argument of ‘f2’, namely + ‘(ly .=. y2 .*. emptyRecord)’ + In the first argument of ‘eq’, namely + ‘f2 (ly .=. y2 .*. emptyRecord)’ + In the expression: f2 (ly .=. y2 .*. emptyRecord) `eq` f1 x y2 + + /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:64:15: error: + • Couldn't match type ‘'[Tagged "x" (BoolN "x"), + Tagged "y" (BoolN "y")]’ + with ‘'[]’ + Expected type: Record '[] + Actual type: HExtendR + (Tagged "x" (BoolN "x")) (Record '[Tagged "y" (BoolN "y")]) + • In the first argument of ‘f2’, namely + ‘(lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’ + In the first argument of ‘eq’, namely + ‘f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord)’ + In the expression: + f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord) `eq` f1 x2 y2 + + /home/aavogt/wip/HList/HList/examples/Properties/KW.hs:65:15: error: + • Couldn't match type ‘'[Tagged "y" (BoolN "y"), + Tagged "x" (BoolN "x")]’ + with ‘'[]’ + Expected type: Record '[] + Actual type: HExtendR + (Tagged "y" (BoolN "y")) (Record '[Tagged "x" (BoolN "x")]) + • In the first argument of ‘f2’, namely + ‘(ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’ + In the first argument of ‘eq’, namely + ‘f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord)’ + In the expression: + f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2 + +-} + it "f1" $ property $ do + (f1 :: BoolN "x" -> BoolN "y") <- arbitrary + x :: BoolN "x" <- arbitrary + x2 :: BoolN "x" <- arbitrary + let f2 (Label :: Label "x") x () = f1 x + f = f2 .*. recToKW [pun| x |] + return $ conjoin + [ kw f lx x2 () `eq` f1 x2, + kw f () `eq` f1 x ] + + -- a function of two arguments can be made into a keyword function + it "f2" $ property $ do + (f1 :: BoolN "x" -> BoolN "y" -> BoolN "z") <- arbitrary + x :: BoolN "x" <- arbitrary + x2 :: BoolN "x" <- arbitrary + y :: BoolN "y" <- arbitrary + y2 :: BoolN "y" <- arbitrary + + let f2 (_ :: Label "x") x (_ :: Label "y") y () = f1 x y + f = f2 .*. recToKW [pun| x y |] + + return $ conjoin + [ kw f lx x2 ly y2 () `eq` f1 x2 y2, + kw f ly y2 lx x2 () `eq` f1 x2 y2, + kw f ly y2 () `eq` f1 x y2, + kw f lx x2 () `eq` f1 x2 y, + kw f () `eq` f1 x y ] + + -- alternatively, a function taking a record is pretty much + -- a keyword argument. Error messages for missing keywords + -- are a bit worse (blame hRearrange') + it "f2Alt" $ property $ do + (f1 :: BoolN "x" -> BoolN "y" -> BoolN "z") <- arbitrary + x :: BoolN "x" <- arbitrary + x2 :: BoolN "x" <- arbitrary + y :: BoolN "y" <- arbitrary + y2 :: BoolN "y" <- arbitrary + + let addDef new = hRearrange (Proxy :: Proxy [Label "x", Label "y"]) (new .<++. [pun| x y |]) + f2 (addDef -> [pun| (x y) |]) = f1 x y + return $ conjoin + [ f2 emptyRecord `eq` f1 x y, + f2 (lx .=. x2 .*. emptyRecord) `eq` f1 x2 y, + f2 (ly .=. y2 .*. emptyRecord) `eq` f1 x y2, + f2 (lx .=. x2 .*. ly .=. y2 .*. emptyRecord) `eq` f1 x2 y2, + f2 (ly .=. y2 .*. lx .=. x2 .*. emptyRecord) `eq` f1 x2 y2 + ] + diff --git a/examples/Properties/LengthDependent.hs b/examples/Properties/LengthDependent.hs new file mode 100644 --- /dev/null +++ b/examples/Properties/LengthDependent.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +-- NOTE: +-- +-- To be able to compile with ghc-7.6 functions like foo are sometimes +-- called +-- +-- $(varE 'foo) because this prevents ghc-7.6 from failing to typecheck +-- the expression (which fails because the number of elements in the +-- supplied HList isn't known until Properties.LengthDependentSplice) +module Properties.LengthDependent where + +#if MIN_VERSION_base(4,9,0) +import qualified Data.Kind as DK +#endif + +import Data.HList.HSort (hMSortBy) +import Data.HList.Variant (eqVariant) +import Data.HList.Record (hZipRecord2) +import Data.HList.HList (hAppend') +import Data.HList.CommonMain + + +#if MIN_VERSION_template_haskell(2,17,0) +import Language.Haskell.TH.Lib.Internal hiding (doE) +import Language.Haskell.TH (Name, mkName, doE) +#else +import Language.Haskell.TH +#endif + +import Test.QuickCheck +import Properties.Common +import Test.Hspec +import Control.Lens +import Data.List (sort,permutations) +import Data.Monoid + +hlN :: Int -> ExpQ +hlN n = [| \proxy -> hSequence + $ $(varE 'hReplicate) $(hNatE n) + (arbitrary `asTypeOf` return proxy) |] + +-- > $(rKN id n) (undefined :: t) :: Arbitrary t => Gen (HList [Record t1, Record t2, ... ]) +-- +-- where +-- t1 ~ '[Tagged 1 t, Tagged 2 t, Tagged 3 t, ... , Tagged n t] +-- t2 ~ '[Tagged 2 t, Tagged 1 t, Tagged 3 t, ... , Tagged n t] +-- tN ~ nth permutation of t1 +rKN :: (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n + -> Int + -> ExpQ +rKN = rKN' (litT . numTyLit) + + +rKN' :: + (Integer -> TypeQ) -- ^ make the label + -> (forall a. [a] -> [a]) -- ^ take some subset of the permutations of 1 .. n + -> Int + -> ExpQ +rKN' mkLab takeK n = [| \proxy -> do + $(recs [| arbitrary `asTypeOf` return proxy |]) + `asTypeOf` return $sig + |] + where sig = [| undefined |] `sigE` quantify [t| HList $(hListT rss) |] + + + ti :: Int -> Name + ti i = mkName ("t" ++ show i) + + recs gen = doE $ + [ bindS (varP (ti i)) gen | i <- [1 .. n] ] ++ + [ noBindS + [| return $ $(hListE + [ [| unlabeled # $(hListE (map (varE . ti) is)) |] + | is <- takeK $ permutations [1 .. n] ]) + |] + ] + + myForallT :: [Name] -> TypeQ -> TypeQ +#if MIN_VERSION_template_haskell(2,17,0) + myForallT ns = forallT [ plainInvisTV n inferredSpec | n <- ns ] (cxt []) +#else + myForallT ns = forallT (map plainTV ns) (cxt []) +#endif + quantify :: TypeQ -> TypeQ + quantify = myForallT [ mkName ("x" ++ show i) | i <- [1 .. n]] + + + rss :: [TypeQ] + rss = takeK $ +#if MIN_VERSION_base(4,9,0) + [ [t| (Record :: [DK.Type] -> DK.Type) $(hListT (map taggedN ns)) |] +#else + [ [t| (Record :: [*] -> *) $(hListT (map taggedN ns)) |] +#endif + | ns <- permutations [1 .. fromIntegral n] ] + + -- taggedN 1 == [t| Tagged 1 x1 |] + taggedN :: Integer -> TypeQ + taggedN i = [t| Tagged $(mkLab i) $(varT (mkName ("x"++show i))) |] + +-- | > $(rN n) :: a -> Record [Tagged 1 a, Tagged 2 a, ... Tagged n a] +rN n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN (take 1) n) proxy |] + + +-- | > $(rNstr n) :: a -> Record [Tagged "1" a, Tagged "2" a, ... Tagged n a] +rNstr n = [| \proxy -> $(varE 'hHead) `fmap` $(rKN' (litT . strTyLit . show) (take 1) n) proxy |] + +vN :: Int -> ExpQ +vN n = [| \proxy -> do + let toV :: Gen (Record a) -> Variant a + toV = undefined + v <- arbitrary + return (v `asTypeOf` toV ($(rN n) proxy)) + |] + +-- specs for 1 HList of length >= 1 +hl1 n1 = [| do + let -- | generate a HList of length nMax containing elements + -- selected from there + genHL proxy = $(hlN n1) proxy + + it "hConcat/hAppend" $ + property $ do + x <- genHL True + y <- genHL True + return $ conjoin [$(varE 'hConcat) ($(varE 'hBuild) x y) == hAppend x y, + $(varE 'hConcat) ($(varE 'hBuild) x y) == hAppend' x y, + $(varE 'hConcat) (hBuild x) == x] + + it "partition" $ + property $ do + x <- genHL True + return $ conjoin + [hPartitionEq (Proxy :: Proxy ConstTrue) (Proxy :: Proxy ()) x `eq` (x, HNil), + hPartitionEq (Proxy :: Proxy ConstFalse) (Proxy :: Proxy ()) x `eq` (HNil, x)] + + + it "listAsHList/hList2List" $ do + property $ do + x <- genHL True + return $ conjoin [ + review listAsHList x `eq` hList2List x, + review listAsHList' x `eq` hList2List x] + + it "read/show" $ + property $ do + xs <- genHL True + return $ read (show xs) == xs + + it "hLength/hReplicate" $ + property $ do + xs <- genHL True + return $ hNat2Integral (hLength xs) == hNat2Integral $(hNatE n1) + + it "hInits last id" $ + property $ do + xs <- genHL True + return $ $(varE 'hLast) (hInits xs) == xs + + it "hInits head empty" $ + property $ do + xs <- genHL True + return $ hHead (hInits xs) == HNil + + it "hTails head id" $ + property $ do + xs <- genHL True + return $ hHead (hTails xs) == xs + + it "hTails last empty" $ + property $ do + xs <- genHL True + return $ $(varE 'hLast) (hTails xs) == HNil + + it "hScanr equals scanr" $ + property $ do + f <- arbitrary + a <- arbitrary + hl <- genHL True + return $ hList2List (hScanr (BinF f) a hl) + == scanr f a (hList2List hl) + + it "hFoldr equals foldr" $ + property $ do + f <- arbitrary + a <- arbitrary + hl <- genHL True + return $ hFoldr (BinF f) a hl == foldr f a (hList2List hl) + + it "hFoldr1 equals foldr1" $ + property $ do + f <- arbitrary + hl <- genHL True + return $ hFoldr1 (BinF f) hl == foldr1 f (hList2List hl) + + it "hFoldl equals foldl" $ + property $ do + f <- arbitrary + a <- arbitrary + hl <- genHL True + return $ hFoldl (BinF f) a hl == foldl f a (hList2List hl) + + it "hSplitAt" $ + property $ do + hl <- genHL True + let n = hLength hl + l = hList2List hl + -- hList2List doesn't like empty lists, and hMapOut id needs + -- annotations, so the following cases are easier to construct + -- than a direct comparison with splitAt + return $ conjoin + [ case hSplitAt hZero hl of + (hNil, hl') -> (hNil `eq` HNil) .&&. (hl' `eq` hl), + case $(varE 'hSplitAt) n hl of + (hl', hNil) -> (hNil `eq` HNil) .&&. (hl' `eq` hl), + + $(varE 'hMap) (HSplitAtAppend hl) ($(varE 'hIterate) (hSucc n) HSuccF hZero) `eq` $(varE 'hReplicate) (hSucc n) hl , + map (\n -> uncurry (++) $ splitAt n l) [0 .. length l] === replicate (length l+1) l + -- the equivalent list-version + ] + + it "hAppend empty is identity" $ + property $ do + x <- genHL (BoolN True :: BoolN "x") + return $ all (== x) [$(varE 'hAppend) HNil x, $(varE 'hAppend) x HNil] + + it "hReverse involution" $ do + property $ do + x <- genHL True + return $ x == $(varE 'hReverse) (hReverse x) + + it "hReverse does nothing for ()" $ + let xs = $(varE 'hReplicate) $(hNatE n1) () + in xs `shouldBe` $(varE 'hReverse) xs + + it "hInit == tail on reverse" $ + property $ do + let hInitReference xs = hReverse (hTail (hReverse xs)) + hl <- genHL True + return $ $(varE 'hInit) hl `eq` $(varE 'hInitReference) hl + + it "hList2List/list2HList" $ property $ do + x <- genHL True + return $ list2HList (hList2List x) === Just x + + it "hMap equals map" $ property $ do + f <- arbitrary + hl <- genHL True + return $ hList2List (hMap f hl) `eq` map (f :: Bool -> BoolN "f") (hList2List hl) + + it "hZip" $ property $ do + x <- genHL (BoolN True :: BoolN "x") + y <- genHL (BoolN True :: BoolN "y") + return $ hList2List (hZip x y) `eq` hList2List x `zip` hList2List y + + it "hZipRecord" $ property $ do + x <- $(rN n1) (BoolN True :: BoolN "x") + y <- $(rN n1) (BoolN True :: BoolN "y") + let r1 = hZip x y ^. unlabeled & hList2List + r2 = hZipRecord2 x y ^. unlabeled & hList2List + r_ = hList2List (x ^. unlabeled) `zip` hList2List (y ^. unlabeled) + + return $ conjoin [ + r1 `eq` r_, + r2 `eq` r_, + hUnzip (hZip x y) `eq` (x,y) ] + + it "hZip/hUnZip" $ property $ do + x <- genHL (BoolN True :: BoolN "x") + y <- genHL (BoolN True :: BoolN "y") + return $ hUnzip (hZip x y) == (x,y) + + it "hUnzip/hZip" $ property $ do + xy <- genHL (BoolN True :: BoolN "x", BoolN True :: BoolN "y") + let (x,y) = hUnzip xy + return $ xy `eq` hZip x y + + it "hUnzip2/hZip2" $ property $ do + xy <- genHL (BoolN True :: BoolN "x", BoolN True :: BoolN "y") + let (x,y) = hUnzip2 xy + return $ xy `eq` hZip2 x y + + -- XXX doesn't work with ghc-7.10.1 + -- (should be fixed for 7.10.2) + it "hZip/hZip2" $ property $ do + x <- genHL (BoolN True :: BoolN "x") + y <- genHL (BoolN True :: BoolN "y") + return $ hZip x y `eq` hZip2 x y + + -- lots of duplication, not sure if it's worth factoring out + it "HList monoid unit" $ + property $ do + x <- genHL (BoolN True :: BoolN "x") + return $ conjoin + [ x === (x `mappend` mempty), + x === (mempty `mappend` x) ] + it "Record monoid unit" $ + property $ do + x <- $(rN n1) (BoolN True :: BoolN "x") + return $ conjoin + [ x === (x `mappend` mempty), + x === (mempty `mappend` x) ] + it "Variant monoid unit" $ + property $ do + x <- $(rN n1) (BoolN True :: BoolN "x") + return $ conjoin + [ x === (x `mappend` mempty), + x === (mempty `mappend` x) ] + + -- lots of duplication, not sure if it's worth factoring out + it "HList monoid assoc" $ + property $ do + x <- genHL (BoolN True :: BoolN "x") + y <- genHL (BoolN True :: BoolN "x") + z <- genHL (BoolN True :: BoolN "x") + return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z)) + it "Record monoid assoc" $ property $ do + x <- $(rN n1) (BoolN True :: BoolN "x") + y <- $(rN n1) (BoolN True :: BoolN "x") + z <- $(rN n1) (BoolN True :: BoolN "x") + return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z)) + it "Variant monoid assoc" $ property $ do + x <- $(vN n1) (BoolN True :: BoolN "x") + y <- $(vN n1) (BoolN True :: BoolN "x") + z <- $(vN n1) (BoolN True :: BoolN "x") + return $ ((x `mappend` y) `mappend` z) `eq` (x `mappend` (y `mappend` z)) + + it "Variant == /eqVariant" $ property $ do + x <- $(vN n1) (BoolN True :: BoolN "x") + y <- $(vN n1) (BoolN True :: BoolN "x") + return $ conjoin [ eqVariant x y == (x == y), + (x == y) == (y == x) ] + + it "Variant ord" $ property $ do + x <- $(vN n1) (BoolN True :: BoolN "x") + y <- $(vN n1) (BoolN True :: BoolN "x") + z <- $(vN n1) (BoolN True :: BoolN "x") + let xyz = [x,y,z] + s:ss = map sort (permutations xyz) + return $ all (s ==) ss + +#if __GLASGOW_HASKELL__ > 707 && __GLASGOW_HASKELL__ < 901 + -- ghc-7.6 has no ordering for Nat (only for HNat) + it "hSort (the labels)" $ property $ do + x <- $(rN n1) True + let rx = x & from hListRecord %~ hReverse + -- rN generates a record that has labels in ascending order already + return $ conjoin [ + x `eq` (x & from hListRecord %~ hSort), + x `eq` (rx & from hListRecord %~ hSort), + x `eq` (x & from hListRecord %~ hMSortBy (Proxy :: Proxy HLeFn)), + x `eq` (rx & from hListRecord %~ hMSortBy (Proxy :: Proxy HLeFn)) + ] + + -- restrict to lists of length 4 (since then the number of permutations + -- is a manageable 24 not 120) + it "hSort permutations" $ property $ do + xs <- $(rKN id (min 4 n1)) True + return $ all (== hHead xs) (hMapOut HSortF xs) + +#endif + + it "hRenameLabel" $ property $ do + r <- $(rN n1) True + return $ conjoin + $(listE [ [| hRenameLabel $ln lx r .!. lx === r .!. $ln |] + | i <- [1 .. n1], + let ln = [| Label :: Label $(litT (numTyLit (fromIntegral i))) |] + ]) +#if __GLASGOW_HASKELL__ < 901 + it "rearranged / hMapR" $ property $ do + r <- $(rN n1) True + let revR = r & from hListRecord %~ hReverse + asT :: x -> As x + asT _ = id + -- hMap works on the reversed list + return $ hMapR not r === (r & rearranged' . asT revR . unlabeled %~ hMap not) +#endif + + + it "hOccurs" $ property $ do + w <- arbitrary :: Gen (BoolN "w") + x <- genHL (BoolN True :: BoolN "x") + y <- genHL (BoolN True :: BoolN "y") + z <- genHL (BoolN True :: BoolN "z") + let xyz = hConcat (hBuild x y z) + hxyz = hEnd (hBuild (hHead x) (hHead y) (hHead z)) + + -- -XNoMonoLocalBinds on ghc <= 7.10.4 allowed + -- having one function + hM1 v = hOccursMany xyz === hList2List v + hM2 v = hOccursMany xyz === hList2List v + hM3 v = hOccursMany xyz === hList2List v + return $ conjoin + [ hM1 x, hM2 y, hM3 z, + hOccurs (hConcat (hBuild x (HCons w HNil) z)) === w, + hOccursOpt xyz === (Nothing `asTypeOf` Just w) + -- hProject hxyz === hBuild (hHead x) (hHead y) + ] + + |] + +hl2 n1 n2 = [| do + it "splitVariant" $ property $ do + x <- $(vN (n1 + n2)) True + let testV :: forall n x yin yout. + (Eq (Variant x), + SplitVariant x yin yout, + HSplitAt n x yin yout, + ExtendsVariant yin x, + ExtendsVariant yout x) => + Proxy n -> Variant x -> Bool + testV n v = case $(varE 'splitVariant) v of + Left a -> extendsVariant (a :: Variant yin) == v + Right a -> extendsVariant (a :: Variant yout) == v + return $ $(varE 'testV) $(hNatE n1) x + + + it "hAppend equals ++" $ + property $ do + x <- $(hlN n1) True + y <- $(hlN n2) True + return $ hList2List (hAppend x y) === hList2List x ++ hList2List y + + it "hTranspose involution" $ property $ do + x <- return (error "hTranspose involution") `asTypeOf` $(hlN n1) True + xx <- $(hlN n2) x + return $ $(varE 'hTranspose) ($(varE 'hTranspose) xx) === xx + + it "leftUnion / unionSR" $ + property $ do + x <- $(rN n1) True + y <- $(rN n2) True + let asL r = r ^. unlabeled . to hList2List + asLs (r1,r2) = (asL r1, asL r2) + merge xs ys = xs ++ drop (length xs) ys + mergeSym xs ys = (merge xs ys, merge ys xs) + eqSorted (a,b) (c,d) = sort a === sort c .&&. sort b === sort d + return $ conjoin [ + asL (x .<++. y) === asL x `merge` asL y, + ($(varE '(.<++.)) x x) === x, + ($(varE '(.<++.)) y y) === y, + asLs (unionSR x y) `eqSorted` mergeSym (asL x) (asL y), + (x `unionSR` x) === (x,x), + (y `unionSR` y) === (y,y)] + + |] + +hl3 n1 n2 n3 = [| do + it "hAppend/hAppendList assoc" $ + property $ do + x <- $(hlN n1) (BoolN True :: BoolN "x") + y <- $(hlN n2) (BoolN True :: BoolN "y") + z <- $(hlN n3) (BoolN True :: BoolN "z") + return $ conjoin +#if __GLASGOW_HASKELL__ < 707 + [ $([| (x `hAppend` y) `hAppend` z |]) === $([| x `hAppend` (y `hAppend` z) |]), + $([| (x `hAppendList` y) `hAppendList` z|]) === $([| x `hAppendList` (y `hAppendList` z)|]) + ] +#else + [ ((x `hAppend` y) `hAppend` z) === (x `hAppend` (y `hAppend` z)), + ((x `hAppendList` y) `hAppendList` z) === (x `hAppendList` (y `hAppendList` z)) + ] +#endif + |] diff --git a/examples/Properties/LengthDependentSplice.hs b/examples/Properties/LengthDependentSplice.hs new file mode 100644 --- /dev/null +++ b/examples/Properties/LengthDependentSplice.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ > 906 +{-# OPTIONS_GHC -freduction-depth=100 #-} +#else +{-# OPTIONS_GHC -fcontext-stack=100 #-} +#endif +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MonoLocalBinds #-} -- maybe it isn't necessary for everything? +module Properties.LengthDependentSplice where +import Properties.LengthDependent +import Language.Haskell.TH +import Test.Hspec + +hl1_2_3 :: Spec +hl1_2_3 = $(doE $ + [ noBindS + [| describe $(stringE (show n)) $(hl1 n) |] + | n <- [1 .. 5]] + ++ [ noBindS [| describe $(stringE (show (n1,n2))) $(hl2 n1 n2) |] + | n1 <- [1 .. 2], + n2 <- [1 .. 2] ] + ++ [ noBindS [| describe $(stringE (show (n1,n2,n3))) $(hl3 n1 n2 n3) |] + | n1 <- [0 .. 2], + n2 <- [0 .. 1], + n3 <- [0 .. 1], + not $ all (==0) [n1,n2,n3] ] + ) diff --git a/examples/Properties/LengthIndependent.hs b/examples/Properties/LengthIndependent.hs new file mode 100644 --- /dev/null +++ b/examples/Properties/LengthIndependent.hs @@ -0,0 +1,688 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +module Properties.LengthIndependent where +import Properties.Common +import Control.Lens +import Data.HList.CommonMain +import Test.Hspec +#if MIN_VERSION_QuickCheck(2,10,1) +import Test.QuickCheck hiding (Fun) +#else +import Test.QuickCheck +#endif +import Data.Monoid +import Data.Maybe +import Control.Applicative +import Control.Monad + +import Data.Generics + +makeLabels3 "lengthindependent" (words "lx_ ly_") + + +-- | tests for a fixed length +hl0 = describe "0 -- length independent" $ do + hTuples + + it "listAsHList" $ property $ do + (f :: Bool -> Bool) <- arbitrary + let bools = [True,False] + mapF (a `HCons` b `HCons` HNil) = f a `HCons` f b `HCons` HNil + len3 = id :: As (HList '[a,b,c]) + len2 = id :: As (HList [a,b]) + len1 = id :: As (HList '[a]) + return $ conjoin + [ (bools & listAsHList %~ mapF) `eq` map f bools, + (bools & listAsHList' . len2 %~ hMap f ) `eq` map f bools, + (bools & listAsHList' . len3 %~ hMap f ) `eq` ([] :: [Bool]), + (bools & listAsHList' . len1 %~ hMap f ) `eq` ([] :: [Bool])] + + it "read0" $ read "H[]" `shouldBe` HNil + + it "Fun" $ property $ do + let plusF = Fun (+1) :: Fun Num '() + x :: Int <- arbitrary + y :: Double <- arbitrary + return $ hMap plusF (hBuild x y) === hEnd (hBuild (x+1) (y+1)) + + it "Fun 2" $ property $ do + let showSuccF = Fun (show . (+1)) :: Fun [Num,Show] String + x :: Int <- arbitrary + y :: Double <- arbitrary + return $ hMapOut showSuccF (hBuild x y) === [ show (x+1), show (y+1)] + + it "Fun'" $ property $ do + x :: Bool <- arbitrary + return $ applyAB (Fun' read :: Fun' Read String) (show x) === x + + it "HComp" $ property $ do + let f = Fun (+1) :: Fun Num '() + g = Fun show :: Fun Show String + gof = g `HComp` f + + x :: Int <- arbitrary + y :: Double <- arbitrary + + let ref = [show (x+1), show (y+1)] + + return $ conjoin [ + hMapOut gof (hBuild x y) `eq` ref, + hMapOut g (hMap f (hBuild x y)) `eq` ref ] + + it "toLabel 1" $ + case hCast (toLabel (hLens' lx)) of + l -> True `const` (l `asTypeOf` Just lx) + + it "toLabel 2" $ case hCast (toLabel lx) of + l -> True `const` (l `asTypeOf` Just lx) + + it "HCast is ==" $ property $ do + x :: BoolN "x" <- arbitrary + x' :: BoolN "x" <- arbitrary + return $ (x == x') ==> (x `eq` x') + + it "HCast neq" $ property $ do + x :: BoolN "x" <- arbitrary + y :: BoolN "y" <- arbitrary + return (expectFailure $ x `eq` y) + + let mkXYvariant = do + (x :: Bool) <- arbitrary + (my :: Maybe Bool) <- arbitrary + return $ (ly .=. my .*. mkVariant1 lx x, + my) + + it "variant lookup/extend" $ do + property $ do + (v, my) <- mkXYvariant + return $ conjoin [ + v .!. ly == my, + v ^? hLens' ly == my, + v ^? hPrism ly == my ] + + it "variant update" $ property $ do + x :: Maybe (BoolN "x") <- arbitrary + x' :: BoolN "x'" <- arbitrary + y :: BoolN "y" <- arbitrary + let v = lx .=. x .*. mkVariant1 ly y + v' | isJust x = lx .=. Just x' .*. mkVariant1 ly y + | otherwise = lx .=. Nothing .*. mkVariant1 ly y + return $ conjoin [ + hUpdateAtLabel lx x' v === v', + (v & hLens' lx .~ x') === v', + (v & hPrism lx .~ x') === v'] + + + it "unvariant" $ do + property $ do + (v, _) <- mkXYvariant + return $ unvariant v == fromJust (msum [v .!. ly, v .!. lx]) + + it "unvarianted" $ property $ do + x :: Maybe Bool <- arbitrary + y :: Bool <- arbitrary + let v = lx .=. x .*. mkVariant1 ly y + vUnitExpected = lx .=. (() <$ x) .*. mkVariant1 ly () + vUnit = v & unvarianted .~ () + vNot = lx .=. (not <$> x) .*. mkVariant1 ly (not y) + return $ conjoin [ + v ^. unvarianted === fromMaybe y x, + (v & unvarianted %~ not) === vNot, + vUnit === vUnitExpected, + vUnit ^. unvarianted === () ] + + it "HMapOutV" $ do + property $ do + (v, _) <- mkXYvariant + return $ hMapOutV not v `eq` not (fromJust (msum [v .!. ly, v .!. lx])) + + it "zipVR" $ property $ do + (f :: BoolN "x" -> BoolN "x'", + g :: BoolN "y" -> BoolN "y'", + b,x,y) <- arbitrary + let p = lx .*. ly .*. emptyProxy + v | b = mkVariant lx x Proxy `asLabelsOf` p + | otherwise = mkVariant ly y Proxy + v' | b = mkVariant lx (f x) Proxy `asLabelsOf` p + | otherwise = mkVariant ly (g y) Proxy + + fun = lx .=. f .*. ly .=. g .*. emptyRecord + + return $ zipVR fun v `eq` v' + + it "zipVariant" $ property $ do + x1 :: Maybe (BoolN "x1") <- arbitrary + x2 :: Maybe (BoolN "x2") <- arbitrary + y1 :: BoolN "y1" <- arbitrary + y2 :: BoolN "y2" <- arbitrary + + let v1 = lx .=. x1 .*. mkVariant1 ly y1 + v2 = lx .=. x2 .*. mkVariant1 ly y2 + + vrT = Proxy :: Proxy '[ Tagged "x" (BoolN "x1", BoolN "x2"), + Tagged "y" (BoolN "y1", BoolN "y2") ] + vr = case (x1,x2) of + (Just a, Just b) -> Just $ mkVariant lx (a,b) vrT + (Nothing, Nothing) -> Just $ mkVariant ly (y1,y2) vrT + _ -> Nothing + + return $ zipVariant v1 v2 `eq` vr + + it "variant Eq" $ property $ do + x1 :: Maybe (BoolN "x") <- arbitrary + x2 :: Maybe (BoolN "x") <- arbitrary + y1 :: BoolN "y" <- arbitrary + y2 :: BoolN "y" <- arbitrary + + let v1 = lx .=. x1 .*. mkVariant1 ly y1 + v2 = lx .=. x2 .*. mkVariant1 ly y2 + return $ (v1 == v2) === (x1 == x2 && (isJust x1 || y1 == y2)) + + + it "projectVariant" $ property $ do + a <- arbitrary + b <- arbitrary + c <- arbitrary + z <- arbitrary + + let vFull :: Variant [Tagged "a" (BoolN "a"), + Tagged "b" (BoolN "b"), + Tagged "c" (BoolN "c"), + Tagged "z" (BoolN "z")] + vFull = a .*. b .*. c .*. mkVariant1 Label z + + isN x = isNothing (untag x) + vZJ :: Variant '[Tagged "z" (BoolN "z")] + vZJ = mkVariant1 Label z + + vZ | isN a, isN b, isN c = Just vZJ + | otherwise = Nothing + + return $ conjoin [ + vFull ^? projected === vZ, + -- XXX maybe projected can be made to work instead of projected' + ((projected' # vZJ) `asTypeOf` vFull) ^? projected === Just vZJ + ] + + it "variant/tic extend" $ do + property $ do + x :: BoolN "x" <- arbitrary + my :: Maybe (BoolN "y") <- arbitrary + let v = ly .=. my .*. mkVariant1 lx x + tic1 = my .*. mkTIC1 x + return $ conjoin + [ -- v == tic1 ^. from typeIndexed, + v^. typeIndexed == tic1 + ] + + + + it "variant/typeIndexed" $ do + property $ do + x :: BoolN "x" <- arbitrary + y :: Maybe (BoolN "y") <- arbitrary + let v = ly .=. y .*. mkVariant1 lx x + let tic = v ^. typeIndexed + return $ conjoin + [ v .!. ly === hOccurs tic, + v .!. ly === tic ^? ticPrism, + v .!. ly `eq` tic .!. (Label :: Label (BoolN "y")), + + v .!. lx === hOccurs tic, + v .!. lx === tic ^? ticPrism, + v .!. lx `eq` tic .!. (Label :: Label (BoolN "x")) + ] + + it "Record/typeIndexed" $ do + property $ do + x :: BoolN "x" <- arbitrary + y :: BoolN "y" <- arbitrary + let r = ly .=. y .*. lx .=. x .*. emptyRecord + tip = r ^. typeIndexed + + asX :: As (BoolN "x") + asX = id + asY :: As (BoolN "y") + asY = id + + return $ conjoin + [ r .!. lx === hOccurs tip, + r .!. lx === tip ^. tipyLens, + r .!. lx `eq` tip .!. (Label :: Label (BoolN "x")), + + -- two ways to apply 'not' to the 'x' field + (r & hLens lx . boolN %~ not) `eq` + (r & typeIndexed %~ ttip (asX . boolN %~ not)), + + -- and repeat everything for the other field + r .!. ly === hOccurs tip, + r .!. ly === tip ^. tipyLens, + r .!. ly `eq` tip .!. (Label :: Label (BoolN "y")), + (r & hLens ly . boolN %~ not) `eq` + (r & typeIndexed %~ ttip (asY . boolN %~ not)) + ] + + -- other operations union, projection etc. + it "Record lookup mixing labels" $ do + property $ do + v1 :: BoolN "v1" <- arbitrary + v2 :: BoolN "v2" <- arbitrary + v3 :: BoolN "v3" <- arbitrary + let l1 = Label :: Label () + l2 = Label :: Label 2 + l3 = Label :: Label "3" + p = Proxy :: Proxy '[Label (), Label 2 , Label "3"] + + p1 = consl1 $ l2 .*. l3 .*. emptyProxy + + -- HExtend doesn't support Label5 + consl1 :: Proxy x -> Proxy (Label () ': x) + consl1 _ = Proxy + + r = hEndR (hBuild v1 v2 v3) `asLabelsOf` p + return $ conjoin + [ r.!.l1 `eq` v1, + r.!.l2 `eq` v2, + p1 `eq` p ] + + it "Record hLookupByLabelM" $ property $ do + v :: BoolN "v" <- arbitrary + w :: BoolN "v" <- arbitrary + let r = [pun| v |] + return $ conjoin + [ hLookupByLabelM (Label :: Label "v") r w `eq` v, + hLookupByLabelM (Label :: Label "w") r w `eq` w ] + + it "HOccurs HList" $ do + property $ do + x <- arbitrary + return $ hOccurs (hEnd (hBuild x)) == (x :: Bool) + + it "HOccurs TIP" $ do + property $ do + x <- arbitrary + return $ hOccurs (hEnd (hBuild x) ^. from tipHList) == (x :: Bool) + + it "HOccurs TIP inference" $ + hOccurs (HCons True HNil^. from tipHList) + `eq` True + + it "tipyLens" $ property $ do + u :: BoolN "u" <- arbitrary + v :: BoolN "v" <- arbitrary + w :: BoolN "w" <- arbitrary + let r = tipHList # hBuild v w + return $ conjoin + [ (r & tipyLens %~ ( \ (_ :: BoolN "v") -> u)) `eq` tipHList # hBuild u w, + (r & tipyLens %~ ( \ (_ :: BoolN "w") -> u)) `eq` tipHList # hBuild v u + ] + + it "ttip 3" $ do + property $ do + f <- arbitrary + (a :: BoolN "a") <- arbitrary + (b :: BoolN "b") <- arbitrary + (c :: BoolN "c") <- arbitrary + let tp = a .*. b .*. c .*. emptyTIP + return $ hOccurs (ttip f tp) == (f a b c :: BoolN "a") + + it "ttipM 3" $ do + property $ do + f <- arbitrary + (a :: BoolN "a") <- arbitrary + (b :: BoolN "b") <- arbitrary + (c :: BoolN "c") <- arbitrary + let tp = a .*. b .*. c .*. emptyTIP + return $ hOccurs (runIdentity (ttipM f tp)) == (runIdentity (f a b c) :: BoolN "a") + + it "Show/Read instances" $ do + show (hEnd (hBuild 1 2 3)) `shouldBe` "H[1,2,3]" + + let r = lx .=. 'x' .*. ly .=. "y" .*. emptyRecord + show r `shouldBe` "Record{x='x',y=\"y\"}" + read (show r) `shouldBe` r + + show (r ^. unlabeled . from tipHList) `shouldBe` "TIPH['x',\"y\"]" + + v <- return $ map ($ r) [mkVariant lx 'a', mkVariant ly "ly"] + + show v `shouldBe` "[V{x='a'},V{y=\"ly\"}]" + read (show v) `shouldBe` v + +#if __GLASGOW_HASKELL__ != 802 && __GLASGOW_HASKELL__ != 804 + -- ghc-8.2.1: typeIndexed' has: Couldn't match with ‘*’ with ‘Symbol’ + -- probably a ghc bug as it (1) works in other version (2) works after in-lining + show (map (^. typeIndexed') v) `shouldBe` "[TIC{char='a'},TIC{[Char]=\"ly\"}]" +#endif + show (map (^. simple . typeIndexed . simple) v) `shouldBe` "[TIC{char='a'},TIC{[Char]=\"ly\"}]" + + it "Data instances gread/gshow" $ do + property $ do + a :: Maybe Bool <- arbitrary + b :: Bool <- arbitrary + let h = hEnd $ hBuild a b + v = lx_ .=. a .*. mkVariant1 ly_ b + r = (unlabeled # h) `asLabelsOf` pLabel3 + + -- ghc-7.8 can't use pLabel5 (due to a lack of Typeable "x") + pLabel3 = lx_ .*. ly_ .*. emptyProxy + pLabel5 = lx .*. ly .*. emptyProxy -- Proxy :: Proxy ["x","y"] + return $ conjoin + [ gread (gshow h) === [(h, "")], + gread (gshow v) === [(v, "")], + gread (gshow r) === [(r, "")] ] + + it "Enum" $ do + show [ mkVariant lx False (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool]) .. maxBound ] + `shouldBe` "[V{x=False},V{x=True},V{y=False},V{y=True}]" + + it "minBound" $ do + mkVariant lx False (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool]) + `shouldBe` minBound + + + + it "projected" $ do + property $ do + (f :: Bool -> Bool -> Bool) <- arbitrary + x :: Bool <- arbitrary + y :: Bool <- arbitrary + let r = lx .=. x .*. ly .=. y .*. lz .=. () .*. emptyRecord + g1 [pun| (x y) |] = case f x y of z -> [pun| z |] + g2 [pun| (y x) |] = case f x y of z -> [pun| z |] + + rExpect = lx .=. x .*. ly .=. y .*. lz .=. f x y .*. emptyRecord + + containX :: Bool <- arbitrary + let + v p | containX = mkVariant lx x p + | otherwise = mkVariant ly y Proxy + + + v1 = v (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool, Tagged "z" Char]) + v2 = v (Proxy :: Proxy '[Tagged "x" Bool, Tagged "y" Bool]) + + v1not = v1 & sameLength . sameLabels . projected %~ hMapV Just . (`asLabelsOf` labelsOf v2) + + + return $ conjoin + [ (r & sameLabels . projected %~ g1) `eq` rExpect + , (r & sameLabels . projected %~ g2) `eq` rExpect + , (v1 ^? projected) === Just v2 + , review projected v2 === v1 + ] + + + it "unboxed" $ do + property $ do + (x :: Bool) <- arbitrary + (y :: Bool) <- arbitrary + (z :: Bool) <- arbitrary + let r = [pun| x y z |] + ru = r ^. unboxed + return $ conjoin + [ ru .!. lx === x, + ru .!. ly === y, + ru .!. lz === z, + hUpdateMany r ru === ru, + hMapRU not ru ^. from unboxed . unlabeled . re listAsHList' + === map not [x,y,z], + r === ru ^. from unboxed ] + + it "unboxedS" $ do + property $ do + (x :: Bool) <- arbitrary + (y :: Int) <- arbitrary + (z :: Int) <- arbitrary + let r = [pun| x y z |] + ru = r ^. unboxedS + return $ conjoin + [ ru .!. lx === x, + ru .!. ly === y, + ru .!. lz === z, + r === ru ^. from unboxedS ] + + it "sortForRecordUS" $ do + property $ do + a :: Bool <- arbitrary + b :: (Bool,Bool) <- arbitrary + c :: Bool <- arbitrary + d :: (Bool,Bool) <- arbitrary + let r = [pun| a b c d |] + sr = sortForRecordUS r + ssr = sortForRecordUS sr + + return $ conjoin + [ sr `eq` ssr, + sr .!. (Label :: Label "a") === a, + sr .!. (Label :: Label "b") === b, + sr .!. (Label :: Label "c") === c, + sr .!. (Label :: Label "d") === d, + hRearrange' sr === r + ] + + + it "monoid0" $ do + mempty `shouldBe` HNil + mempty `shouldBe` emptyRecord + mempty `shouldBe` emptyTIP + mempty `shouldBe` mkVariant1 lx () + mempty `shouldBe` (mkVariant ly () (Proxy :: Proxy '[Tagged "x" [Int], Tagged "y" ()])) + + + it "identity: rearranged relabeled unlabeled" $ do + let r = lx .=. True .*. + ly .=. () .*. emptyRecord + (r ^. rearranged) `shouldBe` r + (r ^. relabeled) `shouldBe` r + (r & unlabeled %~ id) `shouldBe` r + + it "rearranged" $ do + let r = lx .=. True .*. + ly .=. () .*. emptyRecord + let r2 = ly .=. () .*. + lx .=. True .*. emptyRecord + (r ^. rearranged) `shouldBe` r2 + + it "relabeled" $ do + let r = lx .=. True .*. + ly .=. () .*. emptyRecord + let r2 = ly .=. True .*. + lx .=. () .*. emptyRecord + (r ^. relabeled) `shouldBe` r2 + + it "hMaybied" $ property $ do + mx :: Maybe Bool <- arbitrary + my :: Maybe Bool <- arbitrary + let r = lx .=. mx .*. ly .=. my .*. emptyRecord + vT = Proxy :: Proxy [Tagged "x" Bool, Tagged "y" Bool] + (val, v) = case (mx,my) of + (Just x, Nothing) -> (Just x, Just (mkVariant lx x vT)) + (Nothing, Just y) -> (Just y, Just (mkVariant ly y vT)) + _ -> (Nothing, Nothing) + + return $ conjoin [ + (r^?hMaybied <&> unvariant) `eq` val, + isJust v ==> ( hMaybied' # fromJust v === r ) ] + + it "hMaybied 2" $ property $ do + x :: BoolN "x" <- arbitrary + my :: Maybe (BoolN "y") <- arbitrary + let v = ly .=. my .*. mkVariant1 lx x + r = ly .=. my .*. lx .=. Just x .*. emptyRecord + + return $ (r ^? hMaybied) `eq` do + guard $ isNothing my + Just v + + it "hMaybied update" $ property $ do + (f :: BoolN "x" -> BoolN "w",y :: BoolN "y") <- arbitrary + let x = lx .=. (Nothing :: Maybe (BoolN "x")) .*. ly .=. Just y .*. emptyRecord + x' = lx .=. (Nothing :: Maybe (BoolN "w")) .*. ly .=. Just y .*. emptyRecord + + return $ (x & sameLength . hMaybied . hPrism lx %~ f) === x' + + it "hPrism" $ property $ do + x :: Bool <- arbitrary + my :: Maybe (Maybe ()) <- arbitrary + let v = ly .=. my .*. mkVariant1 lx x + v' = ly .=. my .*. mkVariant1 lx (not x) + + tic = my .*. mkTIC1 x + tic' = my .*. mkTIC1 (not x) + + return $ conjoin + [ v' `eq` (v & hPrism lx %~ not), + tic' `eq` (tic & hLens' Label %~ not), + tic' `eq` (tic & ticPrism %~ not) + ] + + it "hDeleteAtLabel" $ property $ do + vx :: BoolN "x" <- arbitrary + vy :: BoolN "y" <- arbitrary + vz :: BoolN "z" <- arbitrary + let r = lx .=. vx .*. ly .=. vy .*. lz .=. vz .*. emptyRecord + ry = ly .=. vy .*. lz .=. vz .*. emptyRecord + rx = lx .=. vx .*. lz .=. vz .*. emptyRecord + + return $ conjoin [ + (r .-. lx) `eq` ry, + (r .-. ly) `eq` rx ] + + it "hBuild/hEndR" $ property $ do + vx :: BoolN "x" <- arbitrary + vy :: BoolN "y" <- arbitrary + vz :: BoolN "z" <- arbitrary + let r = hEndR (hBuild vx vy vz) `asLabelsOf` (lx .*. ly .*. lz .*. emptyProxy) + r_ = lx .=. vx .*. ly .=. vy .*. lz .=. vz .*. emptyRecord + + return $ r `eq` r_ + + + it "hUncurry" $ property $ do + vx :: BoolN "x" <- arbitrary + vy :: BoolN "y" <- arbitrary + vz :: BoolN "z" <- arbitrary + return $ conjoin + [ hUncurry (,,) (hBuild vx vy vz) `eq` (vx,vy,vz), + hCurry (hUncurry (,,)) vx vy vz `eq` (vx,vy,vz), +#if __GLASGOW_HASKELL__ > 948 + hCurry (hUncurry id) vx `eq` vx, +#endif + hCurry ( \(a `HCons` b `HCons` HNil) -> (b,a)) vx vy `eq` (vy,vx) + ] + + it "hCompose" $ property $ do + vx :: BoolN "x" <- arbitrary + vy :: BoolN "y" <- arbitrary + vz :: BoolN "z" <- arbitrary + return $ conjoin + [ hCompose (,) (,) vx vy vz `eq` ((vx,vy), vz) + , hCompose id (,) vx vy `eq` (vx,vy), +#if __GLASGOW_HASKELL__ > 948 + , hCompose (,) id vx vy `eq` (vx,vy) +#endif + ] + + +hTuples = do + it "HTuple0" $ do + HNil ^. hTuple `shouldBe` () + (HNil & hTuple %~ id) `shouldBe` HNil + + it "HTuple2" $ property $ do + a <- arbitrary + b <- arbitrary + let ab = (a :: BoolN "a",b :: BoolN "b") + return $ hBuild a b == ab ^. from hTuple + && hBuild a b ^. hTuple == ab + + it "HTuple3" $ property $ do + a <- arbitrary + b <- arbitrary + c <- arbitrary + let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c") + return $ hBuild a b c == abc ^. from hTuple + && hBuild a b c ^. hTuple == abc + + it "HTuple4" $ property $ do + a <- arbitrary + b <- arbitrary + c <- arbitrary + d <- arbitrary + let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c", + d :: BoolN "d") + return $ hBuild a b c d == abc ^. from hTuple + && hBuild a b c d ^. hTuple == abc + + it "HTuple5" $ property $ do + a <- arbitrary + b <- arbitrary + c <- arbitrary + d <- arbitrary + e <- arbitrary + let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c", + d :: BoolN "d", e :: BoolN "e") + return $ hBuild a b c d e == abc ^. from hTuple + && hBuild a b c d e ^. hTuple == abc + + it "HTuple6" $ property $ do + a <- arbitrary + b <- arbitrary + c <- arbitrary + d <- arbitrary + e <- arbitrary + f <- arbitrary + let abc = (a :: BoolN "a",b :: BoolN "b",c :: BoolN "c", + d :: BoolN "d", e :: BoolN "e", f :: BoolN "f") + return $ hBuild a b c d e f == abc ^. from hTuple + && hBuild a b c d e f ^. hTuple == abc + + + + +-- XXX projected +v = mkVariant (Label :: Label "x") () (Proxy :: Proxy '[Tagged "x" (), Tagged "y" Double]) +vy = mkVariant (Label :: Label "y") 2.4 (Proxy :: Proxy '[Tagged "x" (), Tagged "y" Double]) + +vp1 :: Maybe (Variant '[Tagged "x" ()]) +vp1 = projectVariant v + + +vp1_ = fromJust vp1 + + +vp2 = extendsVariant vp1_ `asTypeOf` v +vp3 = extendsVariant vp1_ `asLabelsOf` v + +vp4 = (v ^? projected) `asTypeOf` vp1 + +vp5 = (projected # fromJust vp1) `asTypeOf` v + + +vm1 = v & sameLength . sameLabels . projected %~ (\x -> x :: Variant '[Tagged "x" ()]) + +vm2 = v & sameLength . sameLabels . projected . sameLabels %~ f2 +vm3 = vy & sameLength . sameLabels . projected . sameLabels %~ f2 + + +f2 (review hMaybied -> [pun| (x) |]) = hBuild (Just (show x)) ^?! hMaybied + +f3 :: Show a => Variant '[Tagged "x" a] -> Variant '[Tagged "x" String] +f3 = unvarianted %~ show + + +hm1 = Proxy :: HMemberM (Tagged "y" Double) '[Tagged "x" (), Tagged "y" Char] inY => Proxy inY + +v2 = fmap (`asLabelsOf` (Proxy :: Proxy '[Label "y"])) (projectVariant v) +v_id = fmap (`asLabelsOf` v) (projectVariant v) +v_id2 = fmap (`asLabelsOf` labelsOf v) (projectVariant v) diff --git a/examples/TIPTransform.hs b/examples/TIPTransform.hs deleted file mode 100644 --- a/examples/TIPTransform.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-} - --- Transforming a TIP: applying to a TIP a (polyvariadic) function --- that takes arguments from a TIP and updates the TIP with the result. --- --- In more detail: we have a typed-indexed collection TIP and we --- would like to apply a transformation function to it, whose argument --- types and the result type are all in the TIP. The function should locate --- its arguments based on their types, and update the TIP --- with the result. The function may have any number of arguments, --- including zero; the order of arguments should not matter. - --- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009. --- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html --- The problem is an interesting variation of the keyword argument problem. - -module TIPTransform where - -import Data.HList - --- We start with the examples - -newtype MyVal = MyVal Int deriving Show - --- A sample TIP -tip1 = MyVal 20 .*. (1::Int) .*. True .*. emptyTIP --- TIP (HCons (MyVal 20) (HCons 1 (HCons True HNil))) - --- Update the Int component of tip1 to 2. The Int component must --- exist. Otherwise, it is a type error -tip2 = ttip (2::Int) tip1 --- TIP (HCons (MyVal 20) (HCons 2 (HCons True HNil))) - --- Negate the boolean component of tip1 -tip3 = ttip not tip1 --- TIP (HCons (MyVal 20) (HCons 1 (HCons False HNil))) - --- Update the Int component from the values of two other components -tip4 = ttip (\(MyVal x) y -> x+y) tip1 --- TIP (HCons (MyVal 20) (HCons 21 (HCons True HNil))) - --- Update the MyVal component from the values of three other components -tip5 = ttip (\b (MyVal x) y -> MyVal $ if b then x+y else 0) tip1 --- TIP (HCons (MyVal 21) (HCons 1 (HCons True HNil))) - --- The same but with the permuted argument order. --- The order of arguments is immaterial: the values will be looked up using --- their types -tip5' = ttip (\b y (MyVal x)-> MyVal $ if b then x+y else 0) tip1 --- TIP (HCons (MyVal 21) (HCons 1 (HCons True HNil))) - --- The implementation - -class TransTIP op db where - ttip :: op -> db -> db - -instance (HMember op db b, TransTIP' b op (TIP db)) - => TransTIP op (TIP db) where - ttip = ttip' (Proxy ::Proxy b) - -class TransTIP' (b :: Bool) op db where - ttip' :: Proxy b -> op -> db -> db - --- If op is found in a TIP, update the TIP with op -instance (HTypeIndexed db, HUpdateAtHNat n op db, HUpdateAtHNatR n op db ~ db, HType2HNat op db n) - => TransTIP' True op (TIP db) where - ttip' _ = tipyUpdate - --- If op is not found in a TIP, it must be a function. Look up --- its argument in a TIP and recur. -instance (HOccurs arg db, TransTIP op db) - => TransTIP' False (arg -> op) db where - ttip' _ f db = ttip (f (hOccurs db)) db - - -main = mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4, - show tip5, show tip5'] diff --git a/examples/TIPTransform.out b/examples/TIPTransform.out deleted file mode 100644 --- a/examples/TIPTransform.out +++ /dev/null @@ -1,6 +0,0 @@ -TIPH[MyVal 20, 1, True] -TIPH[MyVal 20, 2, True] -TIPH[MyVal 20, 1, False] -TIPH[MyVal 20, 21, True] -TIPH[MyVal 21, 1, True] -TIPH[MyVal 21, 1, True] diff --git a/examples/TIPTransform.ref b/examples/TIPTransform.ref deleted file mode 100644 --- a/examples/TIPTransform.ref +++ /dev/null @@ -1,6 +0,0 @@ -TIPH[MyVal 20, 1, True] -TIPH[MyVal 20, 2, True] -TIPH[MyVal 20, 1, False] -TIPH[MyVal 20, 21, True] -TIPH[MyVal 21, 1, True] -TIPH[MyVal 21, 1, True] diff --git a/examples/TIPTransformM.hs b/examples/TIPTransformM.hs deleted file mode 100644 --- a/examples/TIPTransformM.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} -- !TF --- Transforming a TIP: applying to a TIP a (polyvariadic) function --- that takes arguments from a TIP and updates the TIP with the result. --- The monadic version. --- This file contains two versions of the code. --- The comments -- !Simple and -- !TF distinguish the versions --- --- In more detail: we have a typed-indexed collection TIP and we --- would like to apply a transformation function to it, whose argument --- types and the result type are all in the TIP. The function should locate --- its arguments based on their types, and update the TIP --- with the result. The function may have any number of arguments, --- including zero; the order of arguments should not matter. - --- The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009. --- http://www.haskell.org/pipermail/haskell-cafe/2009-September/066217.html --- The problem is an interesting variation of the keyword argument problem. --- In March 2010, Andrew Frank extended the problem for monadic operations. --- This is the monadic version of TIPTransform.hs in the present directory. - - -module TIPTransformM where - -import Data.HList -import Control.Monad.Identity - --- We start with the examples - -newtype MyVal = MyVal Int deriving Show - --- A specialized version of return for the Identity monad. --- It is needed only for the Simple version of the code, --- to tell the type checker the monad in which the computation is --- taking place. --- For the TF version of the code, we can use the ordinary return --- in place of retI. -retI :: a -> Identity a -retI = return - --- A sample TIP -tip1 = MyVal 20 .*. (1::Int) .*. True .*. (3.5::Float) .*. emptyTIP --- TIP (HCons (MyVal 20) (HCons 1 (HCons True (HCons 3.5 HNil)))) - --- Update the Int component of tip1 to 2. The Int component must --- exist. Otherwise, it is a type error --- tip2 = runIdentity $ ttipM (retI (2::Int)) tip1 -- !Simple -tip2 = runIdentity $ ttipM (return (2::Int)) tip1 -- !TF --- TIP (HCons (MyVal 20) (HCons 2 (HCons True (HCons 3.5 HNil)))) - - --- Negate the boolean component of tip1 --- tip3 = runIdentity $ ttipM (retI . not) tip1 -- !Simple -tip3 = runIdentity $ ttipM (return . not) tip1 -- !TF --- TIP (HCons (MyVal 20) (HCons 1 (HCons False (HCons 3.5 HNil)))) - --- Update the Int component from the values of two other components -tip4 = runIdentity $ ttipM (\(MyVal x) y -> retI $ x+y) tip1 --- TIP (HCons (MyVal 20) (HCons 21 (HCons True (HCons 3.5 HNil)))) - --- Update the MyVal component from the values of three other components -tip5 = runIdentity $ - ttipM (\b (MyVal x) y -> retI $ MyVal $ if b then x+y else 0) tip1 --- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil)))) - --- The same but with the permuted argument order. --- The order of arguments is immaterial: the values will be looked up using --- their types -tip5' = runIdentity $ - ttipM (\b y (MyVal x)-> retI $ MyVal $ if b then x+y else 0) tip1 --- TIP (HCons (MyVal 21) (HCons 1 (HCons True (HCons 3.5 HNil)))) - --- Andrew Frank's test --- tip6 :: IO (TIP (HCons MyVal (HCons Int (HCons Bool (HCons Float HNil))))) -tip6 :: IO (TIP (MyVal ': Int ': Bool ': Float ': '[])) -tip6 = ttipM op6 tip1 - -op6 :: MyVal -> Bool -> IO MyVal -op6 (MyVal x) b = do - let m = if b then MyVal (x `div` 4) else MyVal (x * 4) - putStrLn $ "MyVal is now " ++ show m - -- ==>> MyVal 5 - return m --- TIP (HCons (MyVal 5) (HCons 1 (HCons True (HCons 3.5 HNil)))) - - -{- -- !Simple --- The Simple implementation --- The drawback is the need to let the type checker know the monad in which the --- computations take place. That is why we had to use retI in the above --- code, which is a specialized version of return for the Identity monad. --- In op6, the presence of putStrLn unambiguously specified the monad, viz. IO, --- so no special return are required. - -class Monad m => TransTIPM m op db where - ttipM :: op -> db -> m db - --- If the operation is the computation in the desired monad, --- the type of the computation must match an element of TIP. -instance (Monad m, - HTypeIndexed db, HUpdateAtHNat n op db db, HType2HNat op db n) - => TransTIPM m (m op) (TIP db) where - ttipM op db = do - op' <- op - return $ tipyUpdate op' db - --- If op is not a computation in the desired monad m, --- it must be a function. Look up its argument in a TIP and recur. -instance (Monad m, HOccurs arg db, TransTIPM m op db) - => TransTIPM m (arg -> op) db where - ttipM f db = ttipM (f (hOccurs db)) db --} -- !Simple - --- {- -- !TF --- The TF implementation. When specifying the operation to perform over --- a TIP, we can leave it polymorphic over the monad. The type checker --- will instantiate the monad based on the context. - -class Monad m => TransTIPM m op db where - ttipM :: op -> db -> m db - --- Check to see if the operation is a computation whose result --- is in the TIP. The type variable m' of the kind *->* below --- can be instantiated either to a monad type constructor, or (arg->). -instance (Monad m, HMember op db b, TransTIPM' b m (m' op) (TIP db)) - => TransTIPM m (m' op) (TIP db) where - ttipM = ttipM' (Proxy :: Proxy b) - -class Monad m => TransTIPM' (b :: Bool) m op db where - ttipM' :: Proxy b -> op -> db -> m db - --- If op is found in a TIP, update the TIP with op. --- The type variable m' must be equal to the type of the monad --- in which the final result is reported. -instance (Monad m, m ~ m', - HTypeIndexed db, HUpdateAtHNat n op db, HUpdateAtHNatR n op db ~ db, HType2HNat op db n) - => TransTIPM' True m (m' op) (TIP db) where - ttipM' _ op db = do - op' <- op - return $ tipyUpdate op' db - --- If op is not found in a TIP, it must be a function. Look up --- its argument in a TIP and recur. -instance (Monad m, HOccurs arg db, TransTIPM m op db) - => TransTIPM' False m (arg-> op) db where - ttipM' _ f db = ttipM (f (hOccurs db)) db --- -} -- !TF - -main :: IO () -main = do - mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4, - show tip5, show tip5'] - tip2 <- tip6 - putStrLn $ "tip2 is" ++ show tip2 - return () - diff --git a/examples/TIPTransformM.out b/examples/TIPTransformM.out deleted file mode 100644 --- a/examples/TIPTransformM.out +++ /dev/null @@ -1,8 +0,0 @@ -TIPH[MyVal 20, 1, True, 3.5] -TIPH[MyVal 20, 2, True, 3.5] -TIPH[MyVal 20, 1, False, 3.5] -TIPH[MyVal 20, 21, True, 3.5] -TIPH[MyVal 21, 1, True, 3.5] -TIPH[MyVal 21, 1, True, 3.5] -MyVal is now MyVal 5 -tip2 isTIPH[MyVal 5, 1, True, 3.5] diff --git a/examples/TIPTransformM.ref b/examples/TIPTransformM.ref deleted file mode 100644 --- a/examples/TIPTransformM.ref +++ /dev/null @@ -1,8 +0,0 @@ -TIPH[MyVal 20, 1, True, 3.5] -TIPH[MyVal 20, 2, True, 3.5] -TIPH[MyVal 20, 1, False, 3.5] -TIPH[MyVal 20, 21, True, 3.5] -TIPH[MyVal 21, 1, True, 3.5] -TIPH[MyVal 21, 1, True, 3.5] -MyVal is now MyVal 5 -tip2 isTIPH[MyVal 5, 1, True, 3.5] diff --git a/examples/broken/Joy.hs b/examples/broken/Joy.hs new file mode 100644 --- /dev/null +++ b/examples/broken/Joy.hs @@ -0,0 +1,287 @@ +{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fallow-overlapping-instances #-} +{-# OPTIONS -fallow-undecidable-instances #-} + +--Joy implemented in Haskell... extensible embedded language... + +module Joy where + +import MainGhcGeneric1 + +-- Building non-empty lists + +type HOne = HSucc HZero +hOne :: HOne +hOne = undefined +type HTwo = HSucc HOne +hTwo :: HTwo +hTwo = undefined +type HThree = HSucc HTwo +hThree :: HThree +hThree = undefined + +end :: HNil +end = hNil + +instance HList s => Apply HNil s s where + apply _ s = s +instance (HList s,HList s',HList l,Apply a s s',Apply l s' s'') => Apply (HCons a l) s s'' where + apply (HCons a l) s = apply l (apply a s :: s') +instance HList s => Apply HZero s (HCons HZero s) where + apply _ s = hCons hZero s +instance (HNat a,HList s) => Apply (HSucc a) s (HCons (HSucc a) s) where + apply a s = hCons a s + +data Lit a = Lit a +lit :: a -> Lit a +lit a = Lit a +unl :: Lit a -> a +unl (Lit a) = a +instance Show a => Show (Lit a) where + showsPrec _ (Lit a) = showChar '[' . shows a . showChar ']' +instance HList s => Apply (Lit a) s (HCons a s) where + apply (Lit a) s = hCons a s + +class (HBool b,HList s) => HIfte b t f s s' | b t f s -> s' where + hIfte :: b -> t -> f -> s -> s' +instance (HList s,Apply t s s') => HIfte HTrue t f s s' where + hIfte _ t _ s = apply t s +instance (HList s,Apply f s s') => HIfte HFalse t f s s' where + hIfte _ _ f s = apply f s + +data Ifte +ifte :: Ifte +ifte = undefined +instance Show Ifte where + showsPrec _ _ = showString "If" +instance (Apply b s r,HHead r b',HIfte b' t f s s') + => Apply Ifte (f :*: t :*: b :*: s) s' where + apply _ (HCons f (HCons t (HCons b s))) = hIfte (hHead (apply b s :: r) :: b') t f s + +data Nul +nul :: Nul +nul = undefined +instance Show Nul where + showsPrec _ _ = showString "Nul" +instance HList s => Apply Nul (HCons HZero s) (HCons HTrue s) where + apply _ (HCons _ s) = hCons hTrue s +instance HList s => Apply Nul (HCons (HSucc n) s) (HCons HFalse s) where + apply _ (HCons _ s) = hCons hFalse s + +data EQ +eq :: EQ +eq = undefined +instance Show EQ where + showsPrec _ _ = showString "Eq" +instance (HList s,TypeEq a b t) => Apply EQ (HCons a (HCons b s)) (HCons t s) where + apply _ (HCons a (HCons b s)) = hCons (typeEq a b) s + +data Dip +dip :: Dip +dip = undefined +instance Show Dip where + showsPrec _ _ = showString "Dip" +instance (HList s,HList s',Apply a s s') => Apply Dip (HCons a (HCons b s)) (HCons b s') where + apply _ (HCons a (HCons b s)) = hCons b (apply a s) + +data Dup +dup :: Dup +dup = undefined +instance Show Dup where + showsPrec _ _ = showString "Dup" +instance HList s => Apply Dup (HCons a s) (HCons a (HCons a s)) where + apply _ s@(HCons a _) = hCons a s + +data Pop +pop :: Pop +pop = undefined +instance Show Pop where + showsPrec _ _ = showString "Pop" +instance HList s => Apply Pop (HCons a s) s where + apply _ (HCons _ s) = s + +data Swap +swap :: Swap +swap = undefined +instance Show Swap where + showsPrec _ _ = showString "Swap" +instance HList s => Apply Swap (HCons a (HCons b s)) (HCons b (HCons a s)) where + apply _ (HCons a (HCons b s)) = hCons b (hCons a s) + +data Suc +suc :: Suc +suc = undefined +instance Show Suc where + showsPrec _ _ = showString "Suc" +instance (HNat a,HList s) => Apply Suc (HCons a s) (HCons (HSucc a) s) where + apply _ (HCons _ s) = hCons (undefined::HSucc a) s + +data Pre +pre :: Pre +pre = undefined +instance Show Pre where + showsPrec _ _ = showString "Pre" +instance (HNat a,HList s) => Apply Pre (HCons (HSucc a) s) (HCons a s) where + apply _ (HCons _ s) = hCons (undefined::a) s + +data Add +add :: Add +add = undefined +instance Show Add where + showsPrec _ _ = showString "Add" +instance (HList s,HAdd a b c) => Apply Add (HCons a (HCons b s)) (HCons c s) where + apply _ (HCons _ (HCons _ s)) = hCons (hAdd (undefined::a) (undefined::b)) s + +class (HNat a,HNat b) => HAdd a b c | a b -> c where + hAdd :: a -> b -> c +instance HAdd HZero HZero HZero where + hAdd _ _ = hZero +instance HNat b => HAdd HZero (HSucc b) (HSucc b) where + hAdd _ b = b +instance HNat a => HAdd (HSucc a) HZero (HSucc a) where + hAdd a _ = a +instance (HNat (HSucc a),HNat (HSucc b),HNat c,HAdd a b c) + => HAdd (HSucc a) (HSucc b) (HSucc (HSucc c)) where + hAdd _ _ = hSucc $ hSucc $ hAdd (undefined::a) (undefined::b) + +data Sub +sub :: Sub +sub = undefined +instance Show Sub where + showsPrec _ _ = showString "Sub" +instance (HList s,HSub a b c) => Apply Sub (HCons b (HCons a s)) (HCons c s) where + apply _ (HCons _ (HCons _ s)) = hCons (hSub (undefined::a) (undefined::b)) s + +class (HNat a,HNat b) => HSub a b c | a b -> c where + hSub :: a -> b -> c +instance HSub HZero HZero HZero where + hSub _ _ = hZero +instance HNat a => HSub (HSucc a) HZero (HSucc a) where + hSub a _ = a +instance HNat a => HSub HZero (HSucc a) HZero where + hSub _ _ = hZero +instance (HSub a b c) => HSub (HSucc a) (HSucc b) c where + hSub _ _ = hSub (undefined::a) (undefined::b) + +data Mult +mult :: Mult +mult = undefined +instance Show Mult where + showsPrec _ _ = showString "Mult" +instance (HList s,HMult a b c) => Apply Mult (HCons a (HCons b s)) (HCons c s) where + apply _ (HCons _ (HCons _ s)) = hCons (hMult (undefined::a) (undefined::b)) s + +class (HNat a,HNat b) => HMult a b c | a b -> c where + hMult :: a -> b -> c +instance HNat b => HMult HZero b HZero where + hMult _ _ = hZero +instance (HMult a b s,HAdd b s s') => HMult (HSucc a) b s' where + hMult _ _ = hAdd (undefined::b) (hMult (undefined::a) (undefined::b) :: s) + +square = dup .*. mult .*. hNil +cube = mult .*. mult .*. dup .*. dup .*. hNil + +data I +i :: I +i = undefined +instance Show I where + showsPrec _ _ = showString "I" +instance Apply I HNil HNil where + apply _ _ = hNil +instance (HList s,Apply a s s') => Apply I (HCons a s) s' where + apply _ (HCons a s) = apply a s + +data Primrec = Primrec deriving Show +primrec :: Primrec +primrec = undefined +instance Apply z s s' => Apply Primrec (HCons nz (HCons z (HCons HZero s))) s' where + apply _ (HCons _ (HCons z (HCons _ s))) = apply z s +instance (HList s,Apply Primrec (HCons nz (HCons z (HCons n (HCons (HSucc n) s)))) s',Apply nz s' s'') + => Apply Primrec (HCons nz (HCons z (HCons (HSucc n) s))) s'' where + apply _ (HCons nz (HCons z s@(HCons _ _))) = apply nz (apply Primrec (hCons nz (hCons z (hCons (undefined::n) s)))) + +data Times +times :: Times +times = undefined +instance Show Times where + showsPrec _ _ = showString "Times" +instance HList s => Apply Times (HCons p (HCons HZero s)) s where + apply _ (HCons _ (HCons _ s)) = s +instance (HNat n,HList s,HList s',Apply p s s',Apply Times (HCons p (HCons n s')) s'') + => Apply Times (HCons p (HCons (HSucc n) s)) s'' where + apply _ (HCons p (HCons _ s)) = apply times (hCons p (hCons (undefined::n) (apply p s))) + +class (HBool f,HList s) => HGenrec f r1 r2 b t s s'' | f r1 r2 b t s -> s'' where + hGenrec :: f -> r1 -> r2 -> b -> t -> s -> s'' +instance (HList s,Apply t s s') => HGenrec HTrue r1 r2 b t s s' where + hGenrec _ _ _ _ t s = apply t s +instance (HList s,HList s',Apply r1 s s', + Apply (HCons (Lit (HCons (Lit b) (HCons (Lit t) (HCons (Lit r1) (HCons (Lit r2) (HCons Genrec HNil)))))) (HCons r2 HNil)) s' s'') + => HGenrec HFalse r1 r2 b t s s'' where + hGenrec _ r1 r2 b t s = apply (hCons (lit (hCons (lit b) (hCons (lit t) (hCons (lit r1) (hCons (lit r2) (hCons genrec hNil)))))) (hCons r2 hNil)) (apply r1 s :: s') + +data Genrec +genrec :: Genrec +genrec = undefined +instance Show Genrec where + showsPrec _ _ = showString "Genrec" +instance (Apply b s s',HHead s' b',HGenrec b' r1 r2 b t s s'') + => Apply Genrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where + apply _ (HCons r2 (HCons r1 (HCons t (HCons b s)))) + = hGenrec (hHead (apply b s :: s') :: b') r1 r2 b t s + +class (HBool f,HList s) => HLinrec f b t r1 r2 s s' | f b t r1 r2 s -> s' where + hLinrec :: f -> b -> t -> r1 -> r2 -> s -> s' +instance (HList s,Apply t s s') => HLinrec HTrue b t r1 r2 s s' where + hLinrec _ _ t _ _ s = apply t s +instance (HList s,HList s',Apply r1 s s', + Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s')))) s'',Apply r2 s'' s''') + => HLinrec HFalse b t r1 r2 s s''' where + hLinrec _ b t r1 r2 s = apply r2 (apply linrec (hCons r2 (hCons r1 (hCons t (hCons b (apply r1 s :: s'))))) :: s'') + +data Linrec +linrec :: Linrec +linrec = undefined +instance Show Linrec where + showsPrec _ _ = showString "Linrec" +instance (Apply b s s',HHead s' b',HLinrec b' b t r1 r2 s s'') => Apply Linrec (HCons r2 (HCons r1 (HCons t (HCons b s)))) s'' where + apply _ (HCons r2 (HCons r1 (HCons t (HCons b s)))) = hLinrec (hHead (apply b s :: s') :: b') b t r1 r2 s + +data Fact +fact :: Fact +fact = undefined +instance Show Fact where + showsPrec _ _ = showString "Fact" +instance (HList s,Apply (HCons (Lit (HCons (Lit HZero) (HCons EQ HNil))) + (HCons (Lit (HCons Pop (HCons (Lit HOne) HNil))) + (HCons (Lit (HCons Dup + (HCons (Lit HOne) + (HCons Sub (HCons Fact (HCons Mult HNil)))))) + (HCons Ifte HNil)))) s s') => Apply Fact s s' where + apply _ s = apply fac1 s + +fac1 = hCons (lit (hCons (lit hZero) (hCons eq hNil))) + (hCons (lit (hCons pop (hCons (lit hOne) hNil))) + (hCons (lit (hCons dup (hCons (lit hOne) (hCons sub (hCons fact (hCons mult hNil)))))) + (hCons ifte hNil))) + +fac2 = lit (hOne .*. hOne .*. end) + .*. dip .*. lit (dup .*. lit mult .*. dip .*. suc .*. end) + .*. times .*. pop .*. end + +fac3 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end) + .*. lit (i .*. mult .*. end) .*. genrec .*. end + +fac4 = lit nul .*. lit suc .*. lit (dup .*. pre .*. end) + .*. lit mult .*. linrec .*. end + +fac5 = lit hOne .*. lit mult .*. primrec .*. end + +main :: IO () +main = do + putStrLn $ show $ apply (lit hThree .*. fac1 .*. end) end + putStrLn $ show $ apply i (fac2 .*. hThree .*. end) + putStrLn $ show $ apply i (fac3 .*. hThree .*. end) + putStrLn $ show $ apply i (fac4 .*. hThree .*. end) + putStrLn $ show $ apply i (fac5 .*. hThree .*. end) + diff --git a/examples/cmdargs.hs b/examples/cmdargs.hs deleted file mode 100644 --- a/examples/cmdargs.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TemplateHaskell #-} -module Main where -import System.Console.CmdArgs -import Data.HList.CommonMain -import Data.Generics - - -{- - -An example showing off the data instance for Record - -Also a use of cmdArgs - -NOTE: the data instances do not work with ghc-7.8 because of - - - --} - -makeLabels6 (words "x y z") - - -d0 = x .=. (5 :: Int) - .*. y .=. True - .*. z .=. False - .*. emptyRecord - - -data E = E { a :: Int, b, c :: Bool } - deriving (Show, Data, Typeable) -e0 = E 5 True False - -main = do - print d0 - print $ gmapT (mkT not) d0 - print $ gmapT (mkT (+(1::Int))) d0 - - print $ fromConstrB (undefined `extB` (1::Int) `extB` True) undefined `asTypeOf` d0 - - rc <- cmdArgs d0 - print rc - diff --git a/examples/cmdargs.out b/examples/cmdargs.out deleted file mode 100644 --- a/examples/cmdargs.out +++ /dev/null @@ -1,5 +0,0 @@ -Record{x=5,y=True,z=False} -Record{x=5,y=False,z=True} -Record{x=6,y=True,z=False} -Record{x=1,y=True,z=True} -Record{x=5,y=True,z=False} diff --git a/examples/cmdargs.ref b/examples/cmdargs.ref deleted file mode 100644 --- a/examples/cmdargs.ref +++ /dev/null @@ -1,5 +0,0 @@ -Record{x=5,y=True,z=False} -Record{x=5,y=False,z=True} -Record{x=6,y=True,z=False} -Record{x=1,y=True,z=True} -Record{x=5,y=True,z=False} diff --git a/examples/labelable.hs b/examples/labelable.hs deleted file mode 100644 --- a/examples/labelable.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TemplateHaskell, DataKinds, PolyKinds #-} -{- | Demonstrates @hLens'@ - -may be worthwhile to have a lens-free test suite, doing stuff like: - -> case x (Identity . (++"there")) r of Identity t -> t - --} -module Main where -import Data.HList.CommonMain -import Control.Lens - -makeLabelable "x y" - -r = x .==. "hi" .*. - y .==. (y .==. 321 .*. x .==. 123 .*. emptyRecord) .*. - emptyRecord - -main = do - print (r ^. x) - print (r & x .~ ()) - - print (r ^. y . y) - print (r & y . y .~ "xy") diff --git a/examples/labelable.out b/examples/labelable.out deleted file mode 100644 --- a/examples/labelable.out +++ /dev/null @@ -1,4 +0,0 @@ -"hi" -Record{x=(),y=Record{y=321,x=123}} -321 -Record{x="hi",y=Record{y="xy",x=123}} diff --git a/examples/labelable.ref b/examples/labelable.ref deleted file mode 100644 --- a/examples/labelable.ref +++ /dev/null @@ -1,4 +0,0 @@ -"hi" -Record{x=(),y=Record{y=321,x=123}} -321 -Record{x="hi",y=Record{y="xy",x=123}} diff --git a/examples/lens.hs b/examples/lens.hs deleted file mode 100644 --- a/examples/lens.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds #-} -{- | Demonstrates @hLens@. See also labelable.hs which is more "convenient" - --} -module Main where -import Data.HList.CommonMain -import Control.Lens - -makeLabels6 (words "x y") - -r = x .=. "hi" .*. - y .=. (y .=. 321 .*. x .=. 123 .*. emptyRecord) .*. - emptyRecord - -x' a = hLens x a -y' a = hLens y a - -main = do - print (view (hLens x) r) - print (set (hLens x) () r) - - print (r ^. hLens y . hLens x) - print (r & hLens y . hLens y .~ "xy") - - - putStrLn "\n\nand repeat:" - - -- and now for with hLens applied second - print (view x' r) - print (set x' () r) - - print (r ^. y' . y') - print (r & y' . y' .~ "xy") - diff --git a/examples/lens.out b/examples/lens.out deleted file mode 100644 --- a/examples/lens.out +++ /dev/null @@ -1,11 +0,0 @@ -"hi" -Record{x=(),y=Record{y=321,x=123}} -123 -Record{x="hi",y=Record{y="xy",x=123}} - - -and repeat: -"hi" -Record{x=(),y=Record{y=321,x=123}} -321 -Record{x="hi",y=Record{y="xy",x=123}} diff --git a/examples/lens.ref b/examples/lens.ref deleted file mode 100644 --- a/examples/lens.ref +++ /dev/null @@ -1,11 +0,0 @@ -"hi" -Record{x=(),y=Record{y=321,x=123}} -123 -Record{x="hi",y=Record{y="xy",x=123}} - - -and repeat: -"hi" -Record{x=(),y=Record{y=321,x=123}} -321 -Record{x="hi",y=Record{y="xy",x=123}} diff --git a/examples/pun.hs b/examples/pun.hs deleted file mode 100644 --- a/examples/pun.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} --- more examples for record puns -module Main where -import Data.HList.CommonMain - -makeLabels6 (words "a b c") - - -r = c .=. "c" .*. b .=. (a .=. 3 .*. emptyRecord) .*. emptyRecord -r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord - - -p1 ( (.!. b) -> (b @ ((.!. a) -> a))) = (a,b) - -p2 [pun| b @ {a} |] = (a, b) - --- same as p2, but gives a warning --- p3 [pun| b @ a |] = (a, b) - -p4 [pun| b{a} |] = a -- b is not bound - --- adds `x' and `y' into a field called r -e1 = let x = 1; y = "hi" in [pun| r @ { x y } |] - --- updates the `c' field -e2 = let c = 1; y = "hi" in [pun| r @ { c y } |] - --- same as e1, but doesn't use a pre-existing r -e3 = let x = 1; y = "hi" in [pun| r { x y } |] - - -main = do - putStrLn "similar:" - print $ p1 r - print $ p2 r - print $ p4 r - - putStrLn "\nexpression QQ:" - print $ e1 - print $ e2 - print $ e3 - diff --git a/examples/pun.out b/examples/pun.out deleted file mode 100644 --- a/examples/pun.out +++ /dev/null @@ -1,9 +0,0 @@ -similar: -(3,Record{a=3}) -(3,Record{a=3}) -3 - -expression QQ: -Record{r=Record{b=Record{a=3},c="c",x=1,y="hi"}} -Record{r=Record{b=Record{a=3},c=1,y="hi"}} -Record{r=Record{x=1,y="hi"}} diff --git a/examples/pun.ref b/examples/pun.ref deleted file mode 100644 --- a/examples/pun.ref +++ /dev/null @@ -1,9 +0,0 @@ -similar: -(3,Record{a=3}) -(3,Record{a=3}) -3 - -expression QQ: -Record{r=Record{b=Record{a=3},c="c",x=1,y="hi"}} -Record{r=Record{b=Record{a=3},c=1,y="hi"}} -Record{r=Record{x=1,y="hi"}} diff --git a/examples/rundoctests.hs b/examples/rundoctests.hs --- a/examples/rundoctests.hs +++ b/examples/rundoctests.hs @@ -1,10 +1,12 @@ +import Data.List import System.Process import System.Exit import System.IO -import Test.DocTest import Data.Char import System.Environment +import Cabal + -- | tests that all the >>> comments are followed by correct output. Easiest is to -- -- > cabal test @@ -20,21 +22,26 @@ -- you need Cabal >= 1.18 since that's around when cabal repl got added. main = do as <- getArgs - o <- readProcess - "cabal" ["repl","--ghc-options","-v0 -w"] + (ExitSuccess, o, _) <- cabal + ["repl","--ghc-options","-v0 -w"] ":show packages\n:show language" - let flags = words $ unlines $ filter ((=="-") . take 1 . dropWhile isSpace) + let flags = words $ unlines + $ filter (\f -> not $ "package" `isInfixOf` f) + $ filter ((=="-") . take 1 . dropWhile isSpace) $ lines o let files = case as of [] -> ["Data/HList/CommonMain.hs", "Data/HList/HList.hs", "Data/HList/Record.hs", - "Data/HList/Labelable.hs"] + "Data/HList/Labelable.hs", + "Data/HList/HSort.hs"] _ -> as - doctest $ "-i.": "-idist/build/autogen": + let args = "-i.": "-idist/build/autogen": "-optP-include": "-optPdist/build/autogen/cabal_macros.h" : "-Idist/build/autogen" : "-w": files ++ flags + readProcess "doctest" args "" + diff --git a/examples/runexamples.hs b/examples/runexamples.hs deleted file mode 100644 --- a/examples/runexamples.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Main where - -import Control.Exception -import System.FilePath -import Test.Hspec -import System.Process -import System.Exit -import System.Directory -import Data.Maybe -import Control.Monad - -main = do - es <- getDirectoryContents "examples" - print es - -- very dumb - es <- filterM (\e -> allM - [return (takeExtension e == ".hs"), - doesFileExist (dropExtension ("examples"e) ++ ".ref") ]) es - - print es - - hspec $ do - mapM_ runghcwith es - - -runghcwith f = describe f $ it "ok" $ - do - let ex = ("examples" ) - let inFile = ex (takeBaseName f) - outFile = dropExtension inFile ++ ".out" - refFile = dropExtension inFile ++ ".ref" - - (ec, stdout, stderr) <- readProcessWithExitCode "cabal" ["repl","examples", - "-v0", "--ghc-options", "-w -fcontext-stack=50 -iexamples -v0"] - (":set -i\n:set -iexamples\n:load " ++ inFile ++ "\nmain") - - writeFile outFile stdout - - ofe <- doesFileExist refFile - diff <- if ofe then fmap Just $ - readProcess "diff" ["-b", outFile, refFile] "" else return Nothing - - return (ec, stderr, diff) - `shouldReturn` (ExitSuccess, "", Just "") - - - -allM [] = return True -allM (x:xs) = do - x <- x - if x then allM xs else return False