diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,66 @@ +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 diff --git a/Data/HList/CommonMain.hs b/Data/HList/CommonMain.hs --- a/Data/HList/CommonMain.hs +++ b/Data/HList/CommonMain.hs @@ -128,7 +128,8 @@ -- * Conversions between collections -- $convention the foo' optic has the same type as - -- @Control.Lens.simple . foo@. 'hLens'' is an exception to this rule. + -- @Control.Lens.simple . foo . Control.Lens.simple@. + -- 'hLens'' is an exception to this rule. , TypeIndexed(..) , typeIndexed' @@ -162,25 +163,39 @@ , Kw(..), recToKW, IsKeyFN, K, ErrReqdArgNotFound, ErrUnexpectedKW -- * Labels - {- | there are three options for now. However, 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 described - below. 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: - 'makeLabels6' automates definitions like @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 @@ -188,6 +203,14 @@ , module Data.HList.Labelable -- $labelable + -- ** "Data.HList.Dredge" + -- *** lenses + , dredge, dredge' + , dredgeND, dredgeND' + , dredgeTI' + -- *** plain lookup + , hLookupByLabelDredge, HasFieldPath + -- ** namespaced labels , module Data.HList.Label3 @@ -216,7 +239,6 @@ import Data.HList.HOccurs import Data.HList.HTypeIndexed import Data.HList.Record --- import Data.HList.RecordU -- import Data.HList.RecordOrd import Data.HList.HList hiding (append', hAppend', @@ -250,6 +272,8 @@ import Data.HList.Keyword import Data.HList.RecordPuns import Data.HList.RecordU + +import Data.HList.Dredge {- $label6demo #label6demo# diff --git a/Data/HList/Data.hs b/Data/HList/Data.hs --- a/Data/HList/Data.hs +++ b/Data/HList/Data.hs @@ -100,7 +100,9 @@ -- | this data type only exists to have Data instance newtype HListFlat a = HListFlat (HList a) -type DataHListFlatCxt na 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)), @@ -112,8 +114,22 @@ (C (HList a)), HLengthEq a na, - HReplicate na () - ) + HReplicate na ()) + + +-- | ghc-8.0.2 can't work out the type g, +-- in the 2nd argument of gfoldl. ghc <= 7.10 +-- don't need it. +-- +-- in `instance Data (HListFlat '[a,b,c])` +-- +-- > g ~ (a -> b -> c -> HList '[a,b,c]) +-- > g ~ GetG '[a,b,c] (HList '[a,b,c]) +type family FoldRArrow (xs :: [*]) (r :: *) + +type instance FoldRArrow '[] r = r +type instance FoldRArrow (x ': xs) r = x -> FoldRArrow xs r + instance DataHListFlatCxt na g a => Data (HListFlat a) where gfoldl k z (HListFlat xs) = c3 $ 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 @@ -10,15 +10,22 @@ module Data.HList.FakePrelude (module Data.HList.FakePrelude, + -- * re-exports module Data.Proxy, module Data.Tagged, - Monoid(..)) where + Monoid(..), + Any) where import Data.Proxy import Data.Tagged -import GHC.Prim (Constraint) +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 @@ -28,7 +35,7 @@ #endif #if __GLASGOW_HASKELL__ < 709 -import Data.Monoid +import Data.Monoid (Monoid(..)) #endif @@ -285,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) @@ -682,17 +689,54 @@ -- * Error messages --- | A class without instances for explicit failure -class Fail x +{- | 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: --- ** Uses of fail --- $note these could be replaced by `'("helpful message", l)`, --- but these look better. -data ExtraField l -data FieldNotFound l +> (x ~ '( '( '("the", Int), "is wrong") ) ) :: ((,) Symbol *, Symbol) +Therefore code that works across ghc-7.6 through ghc-8.0 needs to +use ErrText, ErrShowType, :<>:, :$$: to construct the type x. -} +class Fail (x :: k) +#if __GLASGOW_HASKELL__ >= 800 +-- | use the alias ErrText to prevent conflicts with Data.Text +-- +-- GHC.TypeLits.:<>: and GHC.TypeLits.:$$: are re-exported +type ErrText x = GHC.TypeLits.Text x +type ErrShowType x = GHC.TypeLits.ShowType x + +-- type Fail = TypeError -- another option +instance TypeError x => Fail x +#else + +type ErrText x = x +type ErrShowType x = x +type x :<>: y = '(x,y) +type x :$$: y = '(x,y) +infixl 6 :<>: +infixl 5 :$$: +#endif + +-- ** Error messages used elsewhere +type FieldNotFound key collection = ErrText "key" :<>: ErrShowType key + :$$: ErrText "could not be found in" :<>: ErrShowType collection + +type ExcessFieldFound key collection = ErrText "found field" :<>: ErrShowType key + :$$: ErrText "when it should be absent from" :<>: ErrShowType collection + +type HNatIndexTooLarge (nat :: HNat) (r :: [k] -> *) (xs :: [k]) = + ErrText "0-based index" :<>: ErrShowType (HNat2Nat nat) :<>: + ErrText "is too large for collection" + :$$: ErrShowType (r xs) + -- :$$: ErrText "(length: " :<>: ErrShowType (HNat2Nat (HLength collection)) :<>: ErrText " )" + -- Data.HList.HList.HLength isn't available here + +type ExtraField x = ErrText "extra field" :<>: ErrShowType x + + #if OLD_TYPEABLE type TypeablePolyK a = (() :: Constraint) #else @@ -730,6 +774,7 @@ 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 diff --git a/Data/HList/HArray.hs b/Data/HList/HArray.hs --- a/Data/HList/HArray.hs +++ b/Data/HList/HArray.hs @@ -47,22 +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 (FieldNotFound (Proxy n, e1)) => HUpdateAtHNat n e1 '[] where +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" + hUpdateAtHNat' _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances" -- -------------------------------------------------------------------------- -- * Projection diff --git a/Data/HList/HList.hs b/Data/HList/HList.hs --- a/Data/HList/HList.hs +++ b/Data/HList/HList.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {- | The HList library @@ -5,9 +6,6 @@ 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 @@ -22,6 +20,10 @@ import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup +#endif + -- -------------------------------------------------------------------------- -- * Heterogeneous type sequences {- $note @@ -173,10 +175,10 @@ 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) - + 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 @@ -490,7 +492,7 @@ 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) +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 @@ -995,17 +997,17 @@ -- * Find an element in a set based on HEq -- | It is a pure type-level operation -class HFind1 e l n => HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n -instance HFind1 e l n => HFind e l n +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]) (n :: HNat) | 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 n) => HFind1 e1 (e2 ': l) n -instance Fail (FieldNotFound e1) => HFind1 e1 '[] HZero +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]) (n:: HNat) | b e l -> n -instance HFind2 True e l HZero -instance HFind1 e l n => HFind2 False e l (HSucc n) +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) @@ -1097,7 +1099,7 @@ -- | @Prism' [a] (HList s)@ -- -- where @s ~ HReplicateR n a@ -listAsHList' x = simple (listAsHList (simple x)) +listAsHList' x = isSimple listAsHList x -- -------------------------------------------------------------------------- @@ -1354,6 +1356,14 @@ 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@ -- @@ -1375,6 +1385,30 @@ 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 @@ -1386,7 +1420,7 @@ hTuple x = iso hToTuple hFromTuple x -- | @Iso' (HList v) a@ -hTuple' x = simple (hTuple x) +hTuple' x = isSimple hTuple x instance HTuple '[] () where hToTuple HNil = () @@ -1599,8 +1633,14 @@ 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 @@ -1612,4 +1652,6 @@ 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 @@ -92,5 +93,45 @@ -- | '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 @@ -82,18 +82,21 @@ 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 (Proxy ::Proxy 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' = error "Data.HList.FakePrelude.Fail must have no instances" +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'. @@ -122,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 --- a/Data/HList/HSort.hs +++ b/Data/HList/HSort.hs @@ -77,6 +77,9 @@ 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 @@ -92,7 +95,8 @@ instance (SameLength a b, HIsAscList le a ok, - HSortBy1 ok le a b) => HSortBy le a b where + HSortBy1 ok le a b, + HEqByFn le) => HSortBy le a b where hSortBy = hSortBy1 (Proxy :: Proxy ok) instance HSortBy1 True le a a where @@ -129,7 +133,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 @@ -143,6 +147,9 @@ 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, @@ -208,7 +215,7 @@ -} class HEqByFn lt => HSetBy lt (ps :: [*]) -instance (HSortBy lt ps ps', HAscList lt ps') => 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 @@ -228,19 +235,23 @@ instance HIsSetBy (HNeq HLeFn) ps b => HIsSet ps b class HEqByFn lt => HIsSetBy lt (ps :: [*]) (b :: Bool) | lt ps -> b -instance (HSortBy lt ps ps', HIsAscList lt ps' b) => HIsSetBy 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 HAscList0 le ps ps => 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) +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 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/Label5.hs b/Data/HList/Label5.hs --- a/Data/HList/Label5.hs +++ b/Data/HList/Label5.hs @@ -3,6 +3,9 @@ {-# LANGUAGE OverlappingInstances #-} {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} #endif +#if __GLASGOW_HASKELL__ > 906 +{-# LANGUAGE LambdaCase #-} +#endif {- | Description: labels are any instance of Typeable @@ -33,7 +36,7 @@ -- | Show label instance {-# OVERLAPPABLE #-} Typeable (x :: *) => ShowLabel x where - showLabel _ = (\(x:xs) -> toLower x:xs) + showLabel _ = (\l -> case l of [] -> [] ; (x:xs) -> toLower x:xs) . reverse . takeWhile (not . (==) '.') . reverse diff --git a/Data/HList/Labelable.hs b/Data/HList/Labelable.hs --- a/Data/HList/Labelable.hs +++ b/Data/HList/Labelable.hs @@ -33,7 +33,7 @@ LabeledCxt1, LabeledTo(LabeledTo), LabeledR(LabeledR), - ToSym(toLabel), + ToSym, EnsureLabel(toLabel), toLabelSym, Identity, LabelableTIPCxt, LabeledOpticType(..), @@ -112,12 +112,24 @@ data LabeledR (x :: [*]) = LabeledR +{- if __GLASGOW_HASKELL__ > 800 +-- should this orphan instance really be supplied? ghc 8's +-- -XOverloadedLabels is uglier syntax than HListPP, and it +-- seems likely that other users of IsLabel probably define +-- an instance for (->) which will be chosen over this one +-- when labels are composed with (.), +-- (or alternatively there will be complaints about overlap) +instance (x ~ x', Labelable x r s t a b) => IsLabel x (LabeledOptic x' r s t a b) where + fromLabel _ = hLens' (Label :: Label x) +-- endif +-} + -- | make a @Lens (Record s) (Record t) a b@ instance HLens x Record s t a b => Labelable x Record s t a b where type LabelableTy Record = LabelableLens - hLens' = hLens + hLens' x = hLens x -- | used with 'toLabel' and/or '.==.' instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where @@ -138,9 +150,12 @@ -- -- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@, -- cannot have an instance of Labelable -instance (TICPrism s t a b, x ~ a, a ~ b, s ~ t, +-- +-- 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 :: *) TIC s t a b where + Labelable (x :: k) TIC s t a b where type LabelableTy TIC = LabelablePrism hLens' _ = ticPrism @@ -150,12 +165,12 @@ -- '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 TIP s t a b where + 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, x ~ a, + (s ~ t, a ~ b, Label x ~ Label a, HLens x TIP s t a b) @@ -167,25 +182,40 @@ infixr 4 .==. +-- | Get the Symbol out of a 'Label' or 'LabeledTo' +class ToSym label (s :: Symbol) | label -> s -{- | Create a @'Label' (x :: 'Symbol')@: +instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3 + => ToSym (v1 v2 v3) x -> toLabel :: LabeledTo x _ _ -> Label x +instance ToSym (label x) x + +{- | Convert a type to @Label :: Label blah@ + +> toLabel :: LabeledTo x _ _ -> Label (x :: Symbol) +> toLabel (hLens' lx) = (lx :: Label x) > toLabel :: Label x -> Label x > toLabel :: Proxy x -> Label x -} -class ToSym label (s :: Symbol) | label -> s where - toLabel :: label -> Label s +class EnsureLabel x y | x -> y where + toLabel :: x -> y -instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3 - => ToSym (v1 v2 v3) x where - toLabel _ = Label +instance EnsureLabel (Label x) (Label (x :: k)) where + toLabel _ = Label -instance ToSym (label x) x where - toLabel _ = Label +instance EnsureLabel (Proxy x) (Label (x :: k)) where + toLabel _ = Label +-- | get the Label out of a 'LabeledTo' (ie. `foobar when using HListPP). +instance ToSym (a b c) (x :: Symbol) => EnsureLabel (a b c) (Label x) where + toLabel _ = Label + +-- | fix the `k` kind variable to 'Symbol' +toLabelSym label = toLabel label `asTypeOf` (Label :: Label (x :: Symbol)) + + {- $comparisonWithhLensFunction Note that passing around variables defined with 'hLens'' doesn't get @@ -206,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, @@ -281,7 +311,7 @@ @Prism' (Variant s) (Variant a)@ -} -projected' s = simple (projected (simple s)) +projected' s = isSimple projected s {- | Together with the instance below, this allows writing 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. @@ -34,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) |] 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 @@ -150,7 +150,9 @@ -- * Unclassified -- | Probably internals, that may not be useful +#if __GLASGOW_HASKELL__ != 706 zipTagged, +#endif HasField'(..), DemoteMaybe, HasFieldM1(..), @@ -196,7 +198,9 @@ 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 () @@ -246,6 +250,7 @@ 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) @@ -261,7 +266,7 @@ hListRecord x = isoNewtype mkRecord (\(Record r) -> r) x -- | @Iso' (HList s) (Record s)@ -hListRecord' x = simple (isoNewtype Record (\(Record r) -> r) x) +hListRecord' x = isSimple hListRecord x -- | Build an empty record emptyRecord :: Record '[] @@ -322,7 +327,7 @@ -- | @Iso' (Record s) (Record a)@ -- -- such that @RecordValuesR s ~ RecordValuesR a@ -relabeled' x = simple (relabeled x) +relabeled' x = isSimple relabeled x data TaggedFn = TaggedFn instance (tx ~ Tagged t x) => ApplyAB TaggedFn x tx where @@ -400,7 +405,8 @@ 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) @@ -465,7 +471,16 @@ instance (HMapCxt HList ReadComponent (AddProxy rs) bs, ApplyAB ReadComponent (Proxy r) readP_r, HProxies rs, - HSequence ReadP (readP_r ': bs) (r ': rs)) => Read (Record (r ': rs)) where + 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 @@ -589,7 +604,8 @@ hLookupByLabel l (Record r) = hLookupByLabel' (Proxy::Proxy b) l r -instance Fail (FieldNotFound l) => HasField l (Record '[]) (FieldNotFound l) where +-- | XXX +instance (t ~ Any, Fail (FieldNotFound l ())) => HasField l (Record '[]) t where hLookupByLabel _ _ = error "Data.HList.Record.HasField: Fail instances should not exist" @@ -724,7 +740,8 @@ => HUpdateAtLabel2 l v (Tagged l' e ': xs) xs' where hUpdateAtLabel2 = hUpdateAtLabel1 (Proxy :: Proxy b) -instance Fail (FieldNotFound l) => HUpdateAtLabel2 l v '[] '[] where +-- | XXX +instance Fail (FieldNotFound l ()) => HUpdateAtLabel2 l v '[] '[] where hUpdateAtLabel2 _ _ r = r @@ -825,6 +842,8 @@ 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) @@ -1055,7 +1074,7 @@ {- | @Iso' (r s) (r a)@ where @s@ is a permutation of @a@ -} -rearranged' x = simple (rearranged (simple x)) +rearranged' x = isSimple rearranged x -- | Helper class for 'hRearrange' class (HRearrange3 ls r r', LabelsOf r' ~ ls, @@ -1094,8 +1113,8 @@ hRearrange4 _ ls (HCons lv@(Tagged v) _HNil) rout = HCons (Tagged v `asTypeOf` lv) (hRearrange3 ls rout) --- | For improved error messages -instance Fail (FieldNotFound l) => +-- | For improved error messages. XXX FieldNotFound +instance Fail (FieldNotFound l ()) => HRearrange4 l ls '[] rout '[] where hRearrange4 _ _ _ _ = error "Fail has no instances" @@ -1234,20 +1253,11 @@ hUnzip = hUnzipRecord -instance (RecordValuesR lvs ~ vs, - SameLabels ls lvs, - LabelsOf lvs ~ ls, - SameLengths [ls,vs,lvs], - HAllTaggedLV lvs) - => HUnzip Proxy ls vs lvs where - hUnzip _ = (Proxy, Proxy) - -instance HUnzip Proxy ls vs lvs - => HZip Proxy ls vs lvs where - hZip _ _ = Proxy - +#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 +a variation on 'hZip' for 'Proxy', where the list of labels does not have to include Label (as in @ts'@) @@ -1275,6 +1285,7 @@ HZip Proxy lts vs tvs) => Proxy ts -> proxy vs -> Proxy tvs zipTagged _ _ = Proxy +#endif 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,27 +55,45 @@ > -- 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. @@ -98,33 +118,18 @@ suppressWarning f (V a) = f (C [V a]) suppressWarning f x = f x --- like \x -> (x .!. x1, x .!. x2) +-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2), +-- where x1 = Label :: Label "x1" extracts xs = do record <- newName "record" - let val = 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)) |], x /= "_" ] - -- constrain the type of the supplied record to have at least - -- as many elements as are extracted. In other words: - -- - -- > f :: r (e1 ': e2 ': e3 ': e4 ': es) -> () -- is inferred - -- > f [pun| { _ _ _ _ } |] = () - ensureLength = [| $(varE record) `asTypeOf` $(minLen xs) |] - - lamE [varP record] [| $val `const` $ensureLength |] - - --- | generates an @undefined :: r xs@, such that @xs :: [k]@ has --- at least as long as the input list -minLen :: [t] -> ExpQ -minLen [] = [| error "Data.HList.RecordPuns.minLen" :: r (es :: [*]) |] -minLen (_ : xs) = [| (error "Data.HList.RecordPuns.minLen" - :: r es -> r (e ': es)) $(minLen xs) |] - mkPair :: String -> ExpQ -> ExpQ mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |] @@ -154,7 +159,7 @@ mp (D as) = conP 'Record - [(foldr ( \ (n,p) xs -> conP 'HCons + [foldr ( \ (n,p) xs -> conP 'HCons [ let ty | n == "_" = [| undefined :: Tagged anyLabel t |] | otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |] @@ -162,7 +167,7 @@ (conP 'Tagged [p]), xs]) (conP 'HNil []) - (mps as))] + (mps as)] mp a = do reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a mp (C [a]) diff --git a/Data/HList/RecordU.hs b/Data/HList/RecordU.hs --- a/Data/HList/RecordU.hs +++ b/Data/HList/RecordU.hs @@ -16,7 +16,6 @@ import Data.HList.Labelable import Unsafe.Coerce -import GHC.Exts (Any) -- * Type definitions -- ** RecordUS @@ -195,7 +194,7 @@ -- ** with the actual representation --- | @Iso (HList s) (HList t) (RecordUS a) (Record b)@ +-- | @Iso (HList s) (HList t) (RecordUS a) (RecordUS b)@ recordUS r = iso hListToRecordUS recordUSToHList r {- | @Iso (HList s) (RecordUS a)@ @@ -204,7 +203,7 @@ is list of @Tagged label value@ -} -recordUS' r = simple (recordUS r) +recordUS' r = isSimple recordUS r -- ** with 'Record' @@ -239,7 +238,7 @@ unboxedS r = iso recordToRecordUS recordUSToRecord r -- | @Iso' (Record x) (RecordUS x)@ -unboxedS' r = simple (unboxedS r) +unboxedS' r = isSimple unboxedS r @@ -327,7 +326,7 @@ unboxed r = iso recordToRecordU recordUToRecord r -- | @Iso' (Record x) (RecordU x)@ -unboxed' x = simple (unboxed x) +unboxed' x = isSimple unboxed x class RecordToRecordU x where @@ -340,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)) @@ -423,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/TIC.hs b/Data/HList/TIC.hs --- a/Data/HList/TIC.hs +++ b/Data/HList/TIC.hs @@ -24,7 +24,9 @@ import Data.HList.HArray import Data.Array (Ix) - +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif import Text.ParserCombinators.ReadP import LensDefs @@ -41,6 +43,7 @@ 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 @@ -52,7 +55,7 @@ ticVariant x = isoNewtype (\(TIC a) -> a) TIC x -- | @Iso' (TIC s) (Variant s)@ -ticVariant' x = simple (ticVariant x) +ticVariant' x = isSimple ticVariant x -- -------------------------------------------------------------------------- @@ -108,7 +111,7 @@ where @s@ has a type like @'[Tagged \"x\" Int]@, and @a@ has a type like @'[Tagged Int Int]@. -} -typeIndexed' x = simple (typeIndexed x) +typeIndexed' x = isSimple typeIndexed x -- -------------------------------------------------------------------------- -- | Public constructor (or, open union's injection function) diff --git a/Data/HList/TIP.hs b/Data/HList/TIP.hs --- a/Data/HList/TIP.hs +++ b/Data/HList/TIP.hs @@ -20,11 +20,17 @@ import Data.HList.HList import Data.HList.Record import Data.HList.HTypeIndexed () -import Data.HList.HOccurs import Data.HList.TIPtuple import Data.List (intercalate) import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif +#if __GLASGOW_HASKELL__ > 710 +import Data.Coerce +#endif + import LensDefs -- -------------------------------------------------------------------------- @@ -34,6 +40,7 @@ -- has type @Tagged e_i e_i@ newtype TIP (l :: [*]) = TIP{unTIP:: HList l} +deriving instance Semigroup (HList a) => Semigroup (TIP a) deriving instance Monoid (HList a) => Monoid (TIP a) deriving instance Eq (HList a) => Eq (TIP a) deriving instance (Ord (HList r)) => Ord (TIP r) @@ -134,9 +141,9 @@ -- | provides a @Lens' (TIP s) a@. 'hLens'' @:: Label a -> Lens' (TIP s) a@ -- is another option. #if __GLASGOW_HASKELL__ < 707 -tipyLens' x = simple (tipyLens x) -- rejected by GHC-7.10RC1 +tipyLens' x = isSimple tipyLens x -- rejected by GHC-7.10RC1 #else -tipyLens' f s = simple (hLens x f) (asTIP s) -- rejected by GHC-7.6.3 +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 @@ -152,16 +159,31 @@ ambiguity as to which field \"a\" should actually be updated. -} -tipyLens f s = hLens x f (asTIP s) +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 - x = getA f - getA :: (a -> f b) -> Label a - getA _ = Label + getN :: HFind (Label a) (LabelsOf s) n => HList s -> (a -> f b) -> Proxy n + getN _ _ = Proxy - asTIP :: TIP a -> TIP a - asTIP = id + -- 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'') @@ -242,7 +264,7 @@ -- | 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 = TagUntagFD (UntagR xs) xs +type UntagTag xs = (TagR (UntagR xs) ~ xs, TagUntagFD (UntagR xs) xs) type family TagR (a :: [*]) :: [*] type family UntagR (ta :: [*]) :: [*] @@ -261,7 +283,7 @@ tipHList x = iso (\(TIP a) -> hUntagSelf a) (TIP . hTagSelf) x -- | @Iso' (TIP (TagR s)) (HList a)@ -tipHList' x = simple (tipHList x) +tipHList' x = isSimple tipHList x -- * conversion to and from 'Record' @@ -272,11 +294,13 @@ tipRecord x = isoNewtype (\(TIP a) -> Record a) (\(Record b) -> TIP b) x -- | @Iso' (TIP (TagR s)) (Record a)@ -tipRecord' x = simple (tipRecord x) +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], @@ -295,6 +319,31 @@ 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))) @@ -350,8 +399,9 @@ => TransTIP1 False (HSucc n) (arg -> op) db where ttip1 _ _ = ttip2 (Proxy :: Proxy b) -instance Fail '(TypeNotFound notfun, "in TIP", db) => TransTIP1 False HZero notfun db where - ttip1 = error "TransTIP1 Fail must have no instances" +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 @@ -361,8 +411,9 @@ => TransTIP2 True arg op db where ttip2 _ f db = ttip (f (hOccurs db)) db -instance Fail '(TypeNotFound arg, "in TIP", db) => TransTIP2 False arg op db where - ttip2 = error "TransTIP2 Fail must have no instances" +instance Fail (FieldNotFound arg (TIP db)) + => TransTIP2 False arg op db where + ttip2 = error "TransTIP2 Fail failed" -- ** Monadic version @@ -400,9 +451,9 @@ op' <- op return $ tipyUpdate op' db -instance (Fail '(TypeNotFound op, "in TIP", db), Monad m) +instance (Fail (FieldNotFound op (TIP db)), Monad m) => TransTIPM1 False HZero m op db where - ttipM1 _ _ = error "TransTIPM1 Fail must have no instances" + 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. @@ -421,9 +472,9 @@ ttipM2 _ f db = ttipM (f (hOccurs db)) db -instance (Fail '(TypeNotFound op, "in TIP", db)) +instance Fail (FieldNotFound op (TIP db)) => TransTIPM2 False m arg op db where - ttipM2 _ _ = error "TransTIPM1 Fail must have no instances" + ttipM2 _ _ = error "TransTIPM1 Fail failed" -- -------------------------------------------------------------------------- diff --git a/Data/HList/Variant.hs b/Data/HList/Variant.hs --- a/Data/HList/Variant.hs +++ b/Data/HList/Variant.hs @@ -27,9 +27,10 @@ import Text.ParserCombinators.ReadP hiding (optional) import Unsafe.Coerce -import GHC.Prim (Any) import GHC.Exts (Constraint) - +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup( .. )) +#endif import Data.Data import Control.Applicative import LensDefs @@ -738,6 +739,8 @@ 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)) @@ -911,22 +914,36 @@ -- * 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 --- | XXX check this mappend is legal 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 diff --git a/Data/HList/broken/VariantOld.hs b/Data/HList/broken/VariantOld.hs deleted file mode 100644 --- a/Data/HList/broken/VariantOld.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# 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 _ = "" - - diff --git a/HList.cabal b/HList.cabal --- a/HList.cabal +++ b/HList.cabal @@ -1,5 +1,5 @@ Name: HList -Version: 0.4.2.0 +Version: 0.5.4.0 Category: Data Synopsis: Heterogeneous lists Description: HList provides many operations to create and manipulate @@ -7,13 +7,21 @@ 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), @@ -22,25 +30,20 @@ Data-files: README, ChangeLog Cabal-version: >= 1.10 -Tested-With: GHC==7.6.3, GHC==7.8.4, GHC==7.10.2 +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/Properties/*.hs, examples/broken/*.hs, examples/broken/*.lhs, - - examples/*.ref, - 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 @@ -55,9 +58,11 @@ See library - Build-Depends: base >= 4.6 && < 4.9, + 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, @@ -69,6 +74,7 @@ Exposed-modules: Data.HList, Data.HList.CommonMain, Data.HList.Data, + Data.HList.Dredge, Data.HList.FakePrelude, Data.HList.HArray, Data.HList.HCurry, @@ -119,7 +125,12 @@ 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 @@ -129,41 +140,66 @@ 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 + Build-Depends: base >= 4.7 && < 4.21 Test-Suite examples Type: exitcode-stdio-1.0 - Ghc-Options: -threaded - Main-Is: runexamples.hs + Main-Is: HListExample.hs Default-Language: Haskell2010 Hs-Source-Dirs: examples - Build-Depends: base, hspec >= 1.7, directory, filepath, - process, syb, cmdargs, lens, HList, mtl + Build-Depends: base < 4.21, hspec >= 1.7, directory, filepath, + hspec-expectations, + process, + syb, + cmdargs, + lens, + HList, + mtl, + QuickCheck, + array, + semigroups, + template-haskell + Other-Modules: + Properties.Common + + HListExample.CmdArgs + HListExample.Datatypes2 + HListExample.Labelable + HListExample.MainGhcGeneric1 + HListExample.MainPosting051106 + HListExample.OverloadedLabels + HListExample.Prism + HListExample.Pun + HListExample.TIPTransform + HListExample.TIPTransformM + if impl(ghc > 7.9) Ghc-Options: -fno-warn-tabs Test-Suite doctests Type: exitcode-stdio-1.0 Ghc-Options: -threaded - if impl(ghc <= 7.9) + 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) => ... - Buildable: False + Build-Depends: base < 4.21, doctest >= 0.8, process + Buildable: False Main-Is: rundoctests.hs Hs-Source-Dirs: examples - Build-Depends: base, doctest >= 0.8, process Default-Language: Haskell2010 Test-Suite properties Type: exitcode-stdio-1.0 - Build-Depends: base, + Build-Depends: base < 4.21, hspec >= 1.7, + hspec-expectations, HList, lens, mtl, @@ -171,6 +207,14 @@ 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 --- a/LensDefs.hs +++ b/LensDefs.hs @@ -22,9 +22,25 @@ type Coercible a b = (() :: Constraint) #endif -simple :: p a (f a) -> p a (f a) -simple = id +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 & 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.8 and GHC-7.10. 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.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,114 +1,4 @@ -#!/usr/bin/runhaskell -\begin{code} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Language.Haskell.Extension - ( Extension(EnableExtension, UnknownExtension, DisableExtension) ) -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package - ( PackageName(PackageName), - PackageId, - InstalledPackageId, - packageVersion, - packageName ) -import Distribution.PackageDescription () -import Distribution.Simple - ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils - ( rewriteFile, createDirectoryIfMissingVerbose ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup () -import Distribution.Simple.LocalBuildInfo () -import System.FilePath ( () ) -import Distribution.Verbosity ( Verbosity ) -import Distribution.PackageDescription () -import Distribution.Simple.LocalBuildInfo () -import Distribution.PackageDescription - ( TestSuite(testName), - PackageDescription, - Library(libBuildInfo), - allExtensions ) -import Distribution.Simple.Compiler () -import Distribution.Simple.Setup - ( BuildFlags(buildVerbosity), - ConfigFlags(..), - Flag(Flag, NoFlag), - fromFlag ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(configFlags), - ComponentLocalBuildInfo(componentPackageDeps), - withTestLBI, - withLibLBI ) -import Data.Maybe - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \ lib libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".flags") $ unlines $ - [ hc , unwords (formatdeps (testDeps libcfg suitecfg) ++ exts lib) ] - where - hc = case configHcPath (configFlags lbi) of - Flag a -> a - NoFlag -> fromMaybe "ghc" (lookup "ghc" (configProgramPaths (configFlags lbi))) - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> "-package=" ++ n ++ "-" ++ showVersion (packageVersion p) - - exts lib = [ "-X" ++ se - | e <- allExtensions (libBuildInfo lib), - Just se <- [case e of - EnableExtension x -> Just (show x) - UnknownExtension x -> Just x - DisableExtension x -> Just ("No" ++ show x) - ] - ] - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - - -\end{code} -Adapted from: - -Copyright 2012-2015 Edward Kmett - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. +#!/usr/bin/env runhaskell -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN -ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGE. +> import Distribution.Simple +> main = defaultMain diff --git a/examples/Cabal.hs b/examples/Cabal.hs deleted file mode 100644 --- a/examples/Cabal.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE CPP #-} -module Cabal where - -import System.Process -import System.Exit -import Control.Monad - --- | > cabal args stdin = readProcessWithExitCode "cabal" args stdin --- --- except it also tries to runghc Setup which can succeed (because --- if things have been configured with runghc Setup, then a different --- version of the Cabal library is chosen and cabal complains instead --- of reconfiguring / using an older Cabal library -cabal :: [String] -> String - -> IO (ExitCode, String, String) -cabal args stdin = do -#if __GLASGOW_HASKELL__ > 707 - cabalRepl @ (ec, _, _) <- readProcessWithExitCode "cabal" args stdin - if ec == ExitSuccess then return cabalRepl - else do - runghcRepl @ (ec2, _, _) <- readProcessWithExitCode "runghc" ("Setup.lhs":args) stdin - when (ec2 /= ExitSuccess) $ do - putStrLn "Could not \"cabal ...\" (exitCode,stdout,stderr):" - print cabalRepl - putStrLn "Could not \"runghc Setup ...\" (exitCode,stdout,stderr):" - print runghcRepl - - putStrLn "\"...\" above is " - putStrLn "Command:" - print ("cabal" : args) - putStrLn "stdin:" - print stdin - return () - - return runghcRepl -#else - -- we don't have a cabal repl (at least if we're using the Cabal that ghc - -- comes with), so read a file written by the ./Setup build - "repl" : tgt : args <- return args - ghc : rest <- lines `fmap` readFile ("dist/build/autogen/Build_" ++ tgt ++ ".flags") - let args2 = "--interactive" - : "-v" - : "-package-db" : "dist/package.conf.inplace" - : concatMap words rest ++ args - - args3 = case break (=="--ghc-options") args2 of - (a, _:_:b) -> a ++ b - print args3 - readProcessWithExitCode ghc args3 stdin -#endif 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/MainGhcGeneric1.hs b/examples/MainGhcGeneric1.hs deleted file mode 100644 --- a/examples/MainGhcGeneric1.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# 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. Because of generic type equality, - this model works with GHC but it does not work with Hugs. - --} - -module MainGhcGeneric1 where - -import Datatypes2 -import Data.HList.CommonMain -import Control.Lens - -asProxy :: proxy a -> Proxy a -asProxy _ = Proxy - - --- -------------------------------------------------------------------------- - -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 $ hBuild 1 ^. from tipHList - print $ null $ hOccurs $ hBuild [] ^. from tipHList - 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 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 --- --- Currently (2014) type signatures are not needed to define tipyTuple. - -tuple l = tipyTuple l - - --- | A specific tuple --- Need to import an instance of TypeEq to be able to run the examples --- oneTrue :: TIP (TagR [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 - print $ ((+) (1::Int)) $ snd $ tuple oneTrue - - -myTipyCow = angus ^. from tipHList - -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 $ 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 .*. hDeleteAtLabel (Label::Label 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 (labelsOf (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 = TagR [Key,Name,Breed,Price] - -testTIC = do - putStrLn "\ntestTIC" - print $ myCol - print $ (hOccurs myCol :: Maybe Breed) - print $ (hOccurs myCol :: Maybe Price) - where - myCol = mkTIC Cow :: TIC AnimalCol - -{- - -myCol = mkTIC Cow :: TIC AnimalCol - -*TIC> hOccurs myCol :: Maybe Breed -Just Cow -*TIC> hOccurs myCol :: Maybe Price -Nothing -*TIC> mkTIC "42" :: TIC AnimalCol -Type error ... -*TIC> hOccurs myCol :: Maybe String -Type error ... - --} - -testVariant = do - putStrLn "\ntestVariant" - print testVar1 - print testVar2 - print testVar3 - where - testVar1 = mkVariant name "angus" animalVar - testVar2 = testVar1 .!. key - testVar3 = testVar1 .!. name - -animalVar = asProxy $ - key .=. (undefined :: Integer) - .*. name .=. (undefined :: String) - .*. breed .=. (undefined :: Breed) - .*. emptyRecord -{- --- -------------------------------------------------------------------------- - -main = mainExport -mainExport - = print $ ( testHArray - , ( testHOccurs - , ( testTypeIndexed - , ( testTuple - , ( testTIP - - , ( testRecords - , ( testRecordsP - , ( testTIC - , ( testVariant - ))))))))) - --} - -main = do - testListBasic - testHArray - testHOccurs - testTypeIndexed - testTuple - testTIP - testRecords - testTIC - testVariant diff --git a/examples/MainGhcGeneric1.ref b/examples/MainGhcGeneric1.ref deleted file mode 100644 --- a/examples/MainGhcGeneric1.ref +++ /dev/null @@ -1,59 +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 -TIC{breed=Cow} -Just Cow -Nothing - -testVariant -V{name="angus"} -Nothing -Just "angus" 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.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,80 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# 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.CommonMain - -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.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,304 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# 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.CommonMain -import Data.Typeable - --- 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.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.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 --- a/examples/Properties.hs +++ b/examples/Properties.hs @@ -1,5 +1,9 @@ {-# 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 #-} @@ -33,11 +37,3 @@ hl0 hl1_2_3 kwSpecs - - - - - - - - diff --git a/examples/Properties/Common.hs b/examples/Properties/Common.hs --- a/examples/Properties/Common.hs +++ b/examples/Properties/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} @@ -10,6 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} module Properties.Common where import Data.HList.CommonMain @@ -17,11 +19,20 @@ 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 @@ -51,6 +62,15 @@ 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), @@ -125,10 +145,20 @@ 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 diff --git a/examples/Properties/KW.hs b/examples/Properties/KW.hs --- a/examples/Properties/KW.hs +++ b/examples/Properties/KW.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} module Properties.KW where @@ -17,6 +18,62 @@ 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 @@ -55,7 +112,7 @@ y :: BoolN "y" <- arbitrary y2 :: BoolN "y" <- arbitrary - let addDef new = hRearrange' (new .<++. [pun| x y |]) + 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, diff --git a/examples/Properties/LengthDependent.hs b/examples/Properties/LengthDependent.hs --- a/examples/Properties/LengthDependent.hs +++ b/examples/Properties/LengthDependent.hs @@ -16,14 +16,24 @@ -- 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 @@ -72,13 +82,23 @@ |] ] + 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] 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 |] @@ -111,6 +131,7 @@ 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" $ @@ -261,14 +282,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" $ @@ -322,7 +346,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 @@ -350,6 +374,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 @@ -357,6 +382,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 @@ -366,9 +392,14 @@ z <- genHL (BoolN True :: BoolN "z") let xyz = hConcat (hBuild x y z) hxyz = hEnd (hBuild (hHead x) (hHead y) (hHead z)) - hM v = hOccursMany xyz === hList2List v + + -- -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 - [ hM x, hM y, hM z, + [ 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) @@ -439,5 +470,3 @@ ] #endif |] - - diff --git a/examples/Properties/LengthDependentSplice.hs b/examples/Properties/LengthDependentSplice.hs --- a/examples/Properties/LengthDependentSplice.hs +++ b/examples/Properties/LengthDependentSplice.hs @@ -1,10 +1,16 @@ -{-# OPTIONS_GHC -fcontext-stack=1000 #-} +{-# 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 @@ -16,11 +22,11 @@ [| describe $(stringE (show n)) $(hl1 n) |] | n <- [1 .. 5]] ++ [ noBindS [| describe $(stringE (show (n1,n2))) $(hl2 n1 n2) |] - | n1 <- [1 .. 3], - n2 <- [1 .. 3] ] + | 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 .. 2], + n3 <- [0 .. 1], not $ all (==0) [n1,n2,n3] ] ) diff --git a/examples/Properties/LengthIndependent.hs b/examples/Properties/LengthIndependent.hs --- a/examples/Properties/LengthIndependent.hs +++ b/examples/Properties/LengthIndependent.hs @@ -8,12 +8,17 @@ {-# 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 @@ -311,6 +316,16 @@ 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 @@ -343,7 +358,12 @@ 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 @@ -431,6 +451,26 @@ 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 @@ -502,9 +542,7 @@ return $ conjoin [ v' `eq` (v & hPrism lx %~ not), - tic' `eq` (tic & hLens' (Label :: Label Bool) %~ not), - -- should work, but it doesn't - -- tic' `eq` (tic & hLens' Label %~ not), + tic' `eq` (tic & hLens' Label %~ not), tic' `eq` (tic & ticPrism %~ not) ] @@ -537,7 +575,9 @@ 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) ] @@ -546,9 +586,12 @@ 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), - hCompose (,) id vx vy `eq` (vx,vy) ] + [ 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 @@ -643,4 +686,3 @@ 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,67 +0,0 @@ -{-# 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 TIPTransform where - -import Data.HList -import Data.Typeable - --- We start with the examples - -newtype MyVal = MyVal Int deriving (Show, Typeable) - --- or if no typeable, use --- instance ShowLabel MyVal where showLabel _ = "MyVal" - --- 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 --- part of HList proper now - - -main = mapM_ putStrLn [show tip1, show tip2, show tip3, show tip4, - show tip5, show tip5'] 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,130 +0,0 @@ -{-# 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 TIPTransformM where - -import Data.HList.CommonMain -import Data.Typeable -import Control.Monad.Identity - --- 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)))) - - -{- -- !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 - -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.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/nn.hs b/examples/broken/nn.hs deleted file mode 100644 --- a/examples/broken/nn.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# OPTIONS_GHC -fcontext-stack=100 #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} - -import Data.HList.CommonMain -import Control.Lens - - -makeLabelable (unwords [ "r" ++ show n | n <- [0 .. 9 :: Int] ]) -r :: RecordU '[Tagged "r0" Int , - Tagged "r1" Int, - Tagged "r2" Int, - Tagged "r3" Int, - Tagged "r4" Int, - Tagged "r5" Int, - Tagged "r6" Int, - Tagged "r7" Int, - Tagged "r8" Int, - Tagged "r9" Int] -r = [1 .. 10] ^?! listAsHList . from unlabeled . unboxed - - - -main = print $ - r^.r0 + - r^.r1 + - r^.r2 + - r^.r3 + - r^.r4 + - r^.r5 + - r^.r6 + - r^.r7 + - r^.r8 + - r^.r9 diff --git a/examples/cmdargs.hs b/examples/cmdargs.hs deleted file mode 100644 --- a/examples/cmdargs.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TemplateHaskell #-} -module Main where -import System.Console.CmdArgs -import Data.HList.CommonMain -import Data.Generics -import Control.Lens -import System.Environment -import GHC.TypeLits (Symbol) -import Data.HList.Labelable(LabeledTo,ToSym) - -{- - -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 --- works for ghc-7.6 -makeLabels6 (words "x y z tic") -makeLabels6 (words "optA optB optC") -#endif - -makeLabelable "abc df" - -#if USE_LABEL3 --- XXX remove extra Label? -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] - -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 - -main = do - print d0 - print $ gmapT (mkT ((+1) :: Double -> Double)) (mkVariant optC 1 v) - print $ (mkVariant optC 1 v) - - print $ gmapT (mkT not) d0 - print $ gmapT (mkT (+(1::Int))) d0 - - 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') - - print $ fromConstrB theB undefined `asTypeOf` d0 - - putStrLn "Cmdargs" - print =<< withArgs ["-a=4", "-b=False" ] (cmdArgs e0) - - -- drop the tic and z fields (which cmdargs doesn't handle) - let dRec = d0 & from hListRecord %~ (hInit . hInit) - print =<< withArgs ["-x=4", "-y=False"] (cmdArgs dRec) diff --git a/examples/cmdargs.ref b/examples/cmdargs.ref deleted file mode 100644 --- a/examples/cmdargs.ref +++ /dev/null @@ -1,9 +0,0 @@ -Record{x=5,y=True,z=V{optC=1.0},tic=TIC{char='x'}} -V{optC=2.0} -V{optC=1.0} -Record{x=5,y=False,z=V{optC=1.0},tic=TIC{char='x'}} -Record{x=6,y=True,z=V{optC=1.0},tic=TIC{char='x'}} -Record{x=1,y=True,z=V{optC=2.5},tic=TIC{char='b'}} -Cmdargs -E {a = 4, b = False} -Record{x=4,y=False} diff --git a/examples/labelable.hs b/examples/labelable.hs deleted file mode 100644 --- a/examples/labelable.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# 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 Main where -import Data.HList.CommonMain -import Control.Lens - -import Text.Read - -makeLabelable "x y" - -#if __GLASGOW_HASKELL__ < 707 -#define INT_SIG_76 :: Int -#else -#define INT_SIG_76 -#endif - -r = x .==. "hi" .*. - y .==. (y .==. 321 .*. x .==. 123 .*. emptyRecord) .*. - emptyRecord - -main = do - print (r ^. x) - print (r & x .~ ()) - - -- ghc-7.6 doesn't default when r is involved lower down, - -- while 7.8.2 does - print (r ^. y . y INT_SIG_76) - print (r ^. y . x INT_SIG_76) - - print (r & y . y .~ "xy") - - putStrLn "\nread-show" - print (readMaybe (show r) `asTypeOf` Just r) - print (readMaybe "Record{x=\"hi\",y=Record{y=321,x=123}}" `asTypeOf` Just r) - - -- there is no permuting of labels - print (readMaybe "Record{y=Record{y=321,x=123},x=\"hi\"}" `asTypeOf` Just r) - - print $ (r ^. rearranged) `asTypeOf` (undefined :: Record '[Tagged "y" t, Tagged "x" s]) diff --git a/examples/labelable.ref b/examples/labelable.ref deleted file mode 100644 --- a/examples/labelable.ref +++ /dev/null @@ -1,11 +0,0 @@ -"hi" -Record{x=(),y=Record{y=321,x=123}} -321 -123 -Record{x="hi",y=Record{y="xy",x=123}} - -read-show -Just Record{x="hi",y=Record{y=321,x=123}} -Just Record{x="hi",y=Record{y=321,x=123}} -Nothing -Record{y=Record{y=321,x=123},x="hi"} diff --git a/examples/lens.hs b/examples/lens.hs deleted file mode 100644 --- a/examples/lens.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# 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 z") - - -#if __GLASGOW_HASKELL__ > 707 -yRec = y .=. 321 .*. x .=. 123 .*. emptyRecord -#else --- defaulting doesn't work in ghc-7.6.3 -yRec = y .=. (321 :: Integer) .*. x .=. (123 :: Integer) .*. emptyRecord -#endif - -r = x .=. "hi" .*. - y .=. yRec .*. - emptyRecord - - -_ = (r^.y') `asTypeOf` hRearrange' - (x .=. 1 .*. y .=. 1 .*. emptyRecord) - -rSmall = x .=. "" .*. 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") - - putStrLn "\n\nIsos" - print (r & sameLength . unlabeled . hTuple . _1 .~ ()) - print (r & sameLength . unlabeled . hTuple . _2 .~ ()) - print (z .=. () .*. r - & unlabeled' . from tipHList %~ ttip (\x z -> x ++ show (z :: ()))) - - r ^. unlabeled . from tipHList & tipPutStrLn - - -tipPutStrLn tip = ttipM ?? tip $ \x -> do - putStrLn x - return x diff --git a/examples/lens.ref b/examples/lens.ref deleted file mode 100644 --- a/examples/lens.ref +++ /dev/null @@ -1,19 +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}} - - -Isos -Record{x=(),y=Record{y=321,x=123}} -Record{x="hi",y=()} -Record{z=(),x="hi()",y=Record{y=321,x=123}} -hi -TIPH["hi",Record{y=321,x=123}] diff --git a/examples/prism.hs b/examples/prism.hs deleted file mode 100644 --- a/examples/prism.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE QuasiQuotes #-} -- for pun -{-# LANGUAGE TemplateHaskell #-} -module Main where -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 - -v = mkVariant left 'x' r - -main = do - putStrLn "Lookup and set" - inspectV - - putStrLn "\nrepeat with Labelable" - inspectV_ - - putStrLn "\nSetting the missing tag does nothing:" - print $ set right_ () v - Left 'x' <- set _Right () (Left 'x') -- prisms for Either do the same thing - & return - - putStrLn "\nLenses compose:" - Nothing <- v3 ^? up_.up_ & return - Just 'x' <- v3 ^? left_ & return - v4 ^? left_.left_ & print - - putStrLn "\nLenses+prisms compose:" - inspectRV - - putStrLn "\n\"extension\"" - extensionTests - - putStrLn "\nInternal Structure:" - putStrLn $ indent $ show vs - - - -lazyX = mkVariant (Label :: Label "x") 'a' lazyProto -lazyY = mkVariant (Label :: Label "y") (2.5 :: Double) lazyProto - -lazyProto = undefined :: Record - '[Tagged "x" x, Tagged "y" y] - -vs = [pun| v v2 v2' v3 v4 v5 v6 v7 |] - -inspectV = do - v ^? hPrism left & print - v ^? hPrism right & print - v ^? hPrism up & print - v2 ^? hPrism left & print - --- note that we can change the type of the 'x' field --- from Char to () -v2 = set (hPrism left) () v - -inspectV_ = do - v ^? left_ & print - v ^? right_ & print - v ^? up_ & print - v2' ^? left_ & print - - -inspectRV = do - r2 ^? down_.left_ & print - r2 ^? down_.right_ & print - r2 ^? du & print - -du = down_.up_ - -r2 = down_ .==. v .*. r - - --- or with the "better" label -v2' = set left_ () v - - -v3 = v & up_ .~ v & up_.up_ .~ "upup" -v4 = v & left_ .~ v & left_.left_ .~ "leftleft" - - -extensionTests = do - Just "hi" <- v5 ^? down_ & return - Just "hi" <- v6 ^? down_ & return - Nothing <- v7 ^? down_ & return - Just 'x' <- v7 ^? left_ & return - return () - - -v5 = down .=. Just "hi" .*. v -v6 = down_ .==. Just "hi" .*. v -v7 = down .=. (Nothing :: Maybe String) .*. v - --- start a newline after every } to make the results readable -indent :: String -> String -indent xs = indent' 0 xs - -indent' n xs | n < 0 = indent' 0 xs -indent' n ('}' : xs) = "}\n" ++ replicate n ' ' ++ indent' (n-4) xs -indent' n ('{' : xs) = '{' : indent' (n+4) xs -indent' n (x : xs) = x : indent' n xs -indent' _ [] = [] diff --git a/examples/prism.ref b/examples/prism.ref deleted file mode 100644 --- a/examples/prism.ref +++ /dev/null @@ -1,37 +0,0 @@ -Lookup and set -Just 'x' -Nothing -Nothing -Just () - -repeat with Labelable -Just 'x' -Nothing -Nothing -Just () - -Setting the missing tag does nothing: -V{left='x'} - -Lenses compose: -Just "leftleft" - -Lenses+prisms compose: -Just 'x' -Nothing -Nothing - -"extension" - -Internal Structure: -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'} - } - diff --git a/examples/pun.hs b/examples/pun.hs deleted file mode 100644 --- a/examples/pun.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# 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.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{x=1,y="hi",c="c",b=Record{a=3}}} -Record{r=Record{c=1,y="hi",b=Record{a=3}}} -Record{r=Record{x=1,y="hi"}} diff --git a/examples/runexamples.hs b/examples/runexamples.hs deleted file mode 100644 --- a/examples/runexamples.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Main where - -import Cabal -import Control.Exception -import System.FilePath -import Test.Hspec -import System.Exit -import System.Process -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" - errFile = dropExtension inFile ++ ".err" - refFile = dropExtension inFile ++ ".ref" - - (ec, stdout, stderr) <- 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] "" - `finally` writeFile errFile stderr - else return Nothing - - unless (diff == Just "") $ writeFile errFile stderr - - return (ec, stderr, diff) - `shouldReturn` (ExitSuccess, "", Just "") - - - -allM [] = return True -allM (x:xs) = do - x <- x - if x then allM xs else return False