diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +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 diff --git a/Data/HList/HSort.hs b/Data/HList/HSort.hs --- a/Data/HList/HSort.hs +++ b/Data/HList/HSort.hs @@ -130,7 +130,7 @@ 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) => +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 diff --git a/Data/HList/HZip.hs b/Data/HList/HZip.hs --- a/Data/HList/HZip.hs +++ b/Data/HList/HZip.hs @@ -98,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/Labelable.hs b/Data/HList/Labelable.hs --- a/Data/HList/Labelable.hs +++ b/Data/HList/Labelable.hs @@ -129,7 +129,7 @@ instance HLens x Record s t a b => Labelable x Record s t a b where type LabelableTy Record = LabelableLens - hLens' = hLens + hLens' x = hLens x -- | used with 'toLabel' and/or '.==.' instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where @@ -167,7 +167,7 @@ instance LabelableTIPCxt x s t a b => Labelable (x :: k) TIP s t a b where type LabelableTy TIP = LabelableLens - hLens' = hLens + hLens' x = hLens x type LabelableTIPCxt x s t a b = (s ~ t, a ~ b, Label x ~ Label a, @@ -236,7 +236,7 @@ > -- 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, 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,26 +55,44 @@ > -- 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 ((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. + +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. diff --git a/Data/HList/RecordU.hs b/Data/HList/RecordU.hs --- a/Data/HList/RecordU.hs +++ b/Data/HList/RecordU.hs @@ -339,7 +339,7 @@ HLengthEq x n, IArray UArray (GetElemTy x) ) => RecordToRecordU x where - recordToRecordU (rx @ (Record x)) = RecordU $ listArray + recordToRecordU (rx@(Record x)) = RecordU $ listArray (0, hNat2Integral (hLength x) - 1) (hList2List (recordValues rx)) @@ -422,11 +422,13 @@ HLensCxt x RecordU s t a b) => Labelable x RecordU s t a b where type LabelableTy RecordU = LabelableLens - hLens' = hLens + 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/TIP.hs b/Data/HList/TIP.hs --- a/Data/HList/TIP.hs +++ b/Data/HList/TIP.hs @@ -160,7 +160,7 @@ -} tipyLens f (TIP s) = case hSplitAt (getN s f) (ghc8fix1 s) of - (x, ta @ (Tagged a) `HCons` ys) + (x, ta@(Tagged a) `HCons` ys) | () <- ghc8fix2 ta -> let mkt b = mkTIP (x `hAppendList` (tagSelf b `HCons` ys)) in mkt <$> f a diff --git a/HList.cabal b/HList.cabal --- a/HList.cabal +++ b/HList.cabal @@ -1,5 +1,5 @@ Name: HList -Version: 0.5.0.0 +Version: 0.5.1.0 Category: Data Synopsis: Heterogeneous lists Description: HList provides many operations to create and manipulate @@ -18,6 +18,10 @@ . 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), @@ -26,7 +30,7 @@ Data-files: README, ChangeLog Cabal-version: >= 1.10 -Tested-With: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1, GHC==8.4.0.20180209 +Tested-With: GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.6, GHC==9.0.1, GHC==9.2.0.20210821 Build-Type: Simple Extra-Source-Files: @@ -54,7 +58,7 @@ See library - Build-Depends: base >= 4.6 && < 4.12, + Build-Depends: base >= 4.6 && < 4.17, -- for Typeable '[] and '(:) with ghc-7.6 base-orphans, -- Data.Semigroup for ghc < 8 @@ -121,6 +125,9 @@ Other-Extensions: CPP TemplateHaskell OverlappingInstances + if impl(ghc >= 8.6) + Default-Extensions: StarIsType + if impl(ghc >= 8.0) Default-Extensions: UndecidableSuperClasses @@ -133,6 +140,7 @@ 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 @@ -163,6 +171,7 @@ HListExample.Labelable HListExample.MainGhcGeneric1 HListExample.MainPosting051106 + HListExample.OverloadedLabels HListExample.Prism HListExample.Pun HListExample.TIPTransform diff --git a/README b/README --- a/README +++ b/README @@ -45,8 +45,18 @@ $ 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, 7.8, 7.10, 8.2 and 8.4.0.20180209. +The code was tested --- within the limits exercised in the source files --- +with GHC: + + - 9.2.0.20210821 + - 9.0.1 + - 8.10.6 + - 8.8.4 + - 8.6.5 + - 8.4.4 + +and may still work with GHC-7.6, 7.8, 7.10, 8.2 + Older compilers are not supported. One may run "cabal test" to check the distribution. diff --git a/examples/HListExample.hs b/examples/HListExample.hs --- a/examples/HListExample.hs +++ b/examples/HListExample.hs @@ -28,6 +28,7 @@ import HListExample.Pun import HListExample.TIPTransform import HListExample.TIPTransformM +import HListExample.OverloadedLabels main = hspec $ do @@ -39,6 +40,7 @@ mainPun mainTIPTransform mainTTIPM + mainOverloadedLabels 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/Pun.hs b/examples/HListExample/Pun.hs --- a/examples/HListExample/Pun.hs +++ b/examples/HListExample/Pun.hs @@ -19,7 +19,7 @@ r2 = b .=. (a .=. 1 .*. emptyRecord) .*. emptyRecord -p1 ( (.!. b) -> (b @ ((.!. a) -> a))) = (a,b) +p1 ( (.!. b) -> (b@((.!. a) -> a))) = (a,b) p2 [pun| b @ {a} |] = (a, b) diff --git a/examples/Properties/LengthDependent.hs b/examples/Properties/LengthDependent.hs --- a/examples/Properties/LengthDependent.hs +++ b/examples/Properties/LengthDependent.hs @@ -24,7 +24,13 @@ 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 @@ -73,8 +79,14 @@ |] ] + 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 ty = forallT [ PlainTV (mkName ("x" ++ show i)) | i <- [1 .. n]] (return []) ty + quantify = myForallT [ mkName ("x" ++ show i) | i <- [1 .. n]] rss :: [TypeQ] @@ -263,14 +275,17 @@ let (x,y) = hUnzip xy return $ xy `eq` hZip x y -#if __GLASGOW_HASKELL__ < 710 + 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 -#endif -- lots of duplication, not sure if it's worth factoring out it "HList monoid unit" $ @@ -324,7 +339,7 @@ s:ss = map sort (permutations xyz) return $ all (s ==) ss -#if __GLASGOW_HASKELL__ > 707 +#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 @@ -352,6 +367,7 @@ | 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 @@ -359,6 +375,7 @@ asT _ = id -- hMap works on the reversed list return $ hMapR not r === (r & rearranged' . asT revR . unlabeled %~ hMap not) +#endif it "hOccurs" $ property $ do