diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,4 +1,13 @@ # trace-embrace changelog +## Version 0.0.3 2025-06-24 + * GHC 9.12 + * Outcome checkers + * ConstArgs - list of ConstArg + * Benchmark execution + * Protection from lost imports + * Call spec cascades + * Include forked HList, multi-containers, refined, conduit-find + ## Version 0.0.1 2025-06-01 * init diff --git a/hlist/Data/HList.hs b/hlist/Data/HList.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE MagicHash #-} +{- | +OOHaskell (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + +This module gathers the API that we need for OOP in Haskell. We +basically select a certain configuration of the HList library, and we +also import modules that are needed for mutable data and monads. Note +on overlapping: Needed for the chosen model of labels. Other models +can be used instead, but the chosen look better in types. +-} + + +module Data.HList ( + + module Data.HList.CommonMain, + -- module Data.HList.RecordAdv, + module Data.STRef, + module Data.IORef, + module Data.Typeable, + module Control.Monad, + module Control.Monad.ST, + module Control.Monad.Fix, +-- module DeepNarrow, +-- module Nominal, +-- module New, +-- module Data.HList.HList + concrete, + (#) +) where + + +import Data.HList.CommonMain hiding ( HDeleteMany + , hDeleteMany + ) + +-- import Data.HList.RecordAdv + +import Data.STRef +import Data.IORef +import Data.Typeable +import Control.Monad +import Control.Monad.ST +import Control.Monad.Fix + +infixr 9 # +(#) :: HasField l r v => r -> Label l -> v +m # field = (m .!. field) + +concrete :: (MonadFix m) => (a -> m a) -> a -> m a +concrete generator self = generator self + where + _ = mfix generator + + diff --git a/hlist/Data/HList/CommonMain.hs b/hlist/Data/HList/CommonMain.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/CommonMain.hs @@ -0,0 +1,331 @@ +{- | + + Description : import me + Copyright : (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + The HList library + + This module re-exports everything needed to use HList. + +-} + +module Data.HList.CommonMain ( + + -- * Faking dependent types in Haskell + module Data.HList.FakePrelude + + -- * Functions for all collections + , module Data.HList.HListPrelude + -- * Array-like access to HLists + , module Data.HList.HArray + -- * Result-type-driven operations + , module Data.HList.HOccurs + -- * Type-indexed operations + , module Data.HList.HTypeIndexed + + -- * Record + , module Data.HList.Record + -- | quasiquoter 'pun' helps to avoid needing a proxy value with + -- type 'Label' in the first place: when you take values out of or into + -- records with pattern matching, the variable name determines the label + -- name. + , module Data.HList.RecordPuns + + -- ** Unpacked / Unboxed Records + , RecordU + , RecordUS + , SortForRecordUS(..) + , HUpdateMany(..) + , hMapRU + + -- *** internals for types + , HFindMany, HNats2Integrals(..) + + , RecordUSCxt + , HLookupByHNatUS, HLookupByHNatUS1 + , HSubtract, HMapUnboxF, UnboxF + , BoxF, EqTagValue, GetElemTy, ElemTyEq + , RecordToRecordU, RecordUToRecord + + -- * HList + -- | A subset of "Data.HList.HList" is re-exported. + , module Data.HList.HList + , module Data.HList.HZip + -- ** A subset of "Data.HList.HSort" + , hSort + , HSort + , HSortBy(..) + , HLeFn, HDown + , HSet, HSetBy + , HIsSet, HIsSetBy + , HAscList, HIsAscList + + -- ** A subset of "Data.HList.HCurry" + , HCurry'(..) + , hCurry, hUncurry + , hCompose + + -- * TIP + -- | Public interface of "Data.HList.TIP" + , TIP + , emptyTIP + , tipyUpdate + , tipyLens + , tipyLens' + -- ** projection + , tipyProject + , tipyProject2 + , tipyTuple + , tipyTuple3 + , tipyTuple4 + , tipyTuple5 + , TagUntag, TagUntagFD(..) + , TagR + + -- ** TIP transform + , TransTIP(..) + , TransTIPM(..) + + -- * TIC + -- | Public interface of "Data.HList.TIC" + , TIC + -- ** creating TIC + , mkTIC + , mkTIC1 + , mkTIC' + + -- ** get,set,modify + , ticPrism, ticPrism' + + -- * Variant + -- | Public interface of "Data.HList.Variant" + , Variant + , mkVariant + , mkVariant1 + , castVariant + , HMapV(..), hMapV + , hMapOutV + , ZipVariant(..) + , ZipVR(..), zipVR + -- ** projection + -- *** many + , SplitVariant(splitVariant) + , ProjectVariant(..) + , ExtendsVariant(..) + , ProjectExtendVariant(..) + -- *** one + , HPrism(..) + , unvarianted, unvarianted' + + , splitVariant1 + , splitVariant1' + , extendVariant + -- **** implementation + , Unvariant(..) + , Unvariant'(..) + + + + -- * Conversions between collections + -- $convention the foo' optic has the same type as + -- @Control.Lens.simple . foo . Control.Lens.simple@. + -- 'hLens'' is an exception to this rule. + + , TypeIndexed(..) + , typeIndexed' + -- ** HList and Record + -- | 'unlabeled' 'unlabeled'' + + -- ** HList and TIP + , tipHList, tipHList' + -- ** Record and RecordU + , unboxed, unboxed' + -- ** Record and RecordUS + , unboxedS, unboxedS' + -- ** Record and Variant + , hMaybied, hMaybied' + + -- ** Newtype wrappers + -- $convention these isos unwrap/wrap the newtypes 'TIP' 'TIC' and + -- 'Record'. Names follow the pattern @fromTo :: Iso' From To@. + + -- | 'hListRecord' 'hListRecord'' are exported under "Data.HList.Record" + , ticVariant, ticVariant' + , tipRecord, tipRecord' + + -- *** implementation + , VariantToHMaybied(variantToHMaybied) + , HMaybiedToVariantFs + , hMaybiedToVariants + + -- * "Data.HList.Keyword" + -- | the \"public\" parts. More examples are in the module documentation. + , Kw(..), recToKW, IsKeyFN, K, ErrReqdArgNotFound, ErrUnexpectedKW + + -- * Labels + {- | By labels, we mean either the first argument to 'Tagged' (in the + type-level lists that are supplied to 'Record', 'RecordU', 'TIP', 'TIC'), + or the expressions used to specify those types to be able to look up + the correct value in those collections. + + Nearly all types can be labels. For example: + + @ + r :: Record '[Tagged "x" Int, -- kind GHC.TypeLits.Symbol + Tagged () (), -- see "Data.HList.Label5" + Tagged (Lbl HZero LabelUniverse LabelMember1) () -- Label3 + ] + r = 'hBuild' 8 () () -- don't need to use '.=.' / '.==.' and '.*.' + -- if we have a type signature above + @ + + we could define these variables + + @ + xLabel = Label :: Label \"x\" -- 'makeLabels6' ["x"] would define x with the same RHS + xLens = hLens' xLabel -- 'makeLabelable' "x" would define x with the same RHS + @ + + to access the @8@ given above: + + @ + r '.!.' xLabel + r ^. xLens -- alternatively Control.Lens.view + r ^. `x -- with HListPP is used (not in ghci), + -- which avoids the issue of conflicting + -- definitions of x, which mean the same + -- thing + @ + + -} + -- $label6demo + + , module Data.HList.Labelable + -- $labelable + + -- ** "Data.HList.Dredge" + -- *** lenses + , dredge, dredge' + , dredgeND, dredgeND' + , dredgeTI' + -- *** plain lookup + , hLookupByLabelDredge, HasFieldPath + + -- ** namespaced labels + , module Data.HList.Label3 + + -- ** labels as any instance of Typeable + -- | "Data.HList.Label5" + + -- ** template haskell + , module Data.HList.MakeLabels + + + -- * "Data.HList.Data" + -- | This modules provide useful instances. A useful application can be + -- found in @examples/cmdargs.hs@ + + -- | Overlapping instances are restricted to here + , module Data.HList.TypeEqO + + -- * Internals + -- | internals exported for type signature purposes + , HAllTaggedEq +) where + +import Data.HList.FakePrelude +import Data.HList.HListPrelude +import Data.HList.HArray +import Data.HList.HOccurs +import Data.HList.HTypeIndexed +import Data.HList.Record +-- import Data.HList.RecordOrd +import Data.HList.HList hiding (append', + hAppend', + FHCons(..), + hMapAux, + MapCar(..), + hMapMapCar, + hSequence2, + ) +import Data.HList.HCurry +import Data.HList.HSort +import Data.HList.MakeLabels +import Data.HList.TypeEqO hiding (IsKeyFN) +import Data.HList.TIP +import Data.HList.TIC + +import Data.HList.HZip +import Data.HList.Label3 hiding (MapLabel) +import Data.HList.Label5 () -- only instances +import Data.HList.Label6 () -- only instances +import Data.HList.Labelable (Labelable(..), + Projected(..), projected', + toLabel, + (.==.), + LabeledOptic) + +import Data.HList.Variant + +import Data.HList.Data () -- only instances + +import Data.HList.Keyword +import Data.HList.RecordPuns +import Data.HList.RecordU + +import Data.HList.Dredge + +{- $label6demo #label6demo# + + Instances from "Data.HList.Label6" + +>>> :set -XDataKinds +>>> (Label :: Label "x") .=. (5::Int) .*. emptyRecord +Record{x=5} + +>>> let x = Label :: Label "x" +>>> let r = x .=. (5::Int) .*. emptyRecord +>>> r .!. x +5 + +-} + +{- $labelable #labelabledemo# + +Rather than having the @x = Label :: Label \"x\"@, the labels +generated by 'makeLabelable' also double as lenses for "Control.Lens". +Here is an example of how much better that is: + +>>> :set -XNoMonomorphismRestriction -XDataKinds -XPolyKinds +>>> import Control.Lens +>>> import Data.HList.Labelable +>>> let x = hLens' (Label :: Label "x") +>>> let y = hLens' (Label :: Label "y") + +The Label6 method: + +>>> let r = (Label :: Label "x") .=. "5" .*. emptyRecord + +The Labelable way: + +>>> let r2 = x .==. "5" .*. emptyRecord + +>>> r ^. x +"5" + +>>> r2 ^. x +"5" + +>>> r & x .~ () +Record{x=()} + +When a field is missing, the error names that field: + +>>> :t r^.y +... +...No instance for (Fail (FieldNotFound "y")) +... + +-} + + diff --git a/hlist/Data/HList/Data.hs b/hlist/Data/HList/Data.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Data.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE CPP #-} + +{- | Description: Data instances + + +'Data.Data.Data' instances for 'HListFlat' and 'Record' which pretend +to be flat data structures. The @Data@ instance for 'HList' gives a nested +structure. + +NOTE: these instances do not work with ghc-7.8 with promoted +string (Symbol) labels because of + + +[@HList@] + +The data instance for + +> a :: HList '[Int, Double, b] + +Looks like the same instance for + +> type T b = (Int, (Double, (b, ()))) + + +[@HListFlat@] + +The Data instance for + +> a :: Data b => HListFlat '[Int,Double,b] + +will look like the Data instance for: + +> data A b = A Int Double b + + +[@Record@] + +For 'Record' similar ideas apply. An + +> a :: Record '[ LVPair "x" Int, LVPair "y" Double ] + +should behave like a: + +> data A = A { x :: Int, y :: Double } deriving (Data) + +Many unsafecoerces are necessary here because the Data class includes type +parameters @c@ that cannot be used in the class context for the instance. +Perhaps there is another way. + +-} +module Data.HList.Data ( + -- * exports for type signatures/ haddock usage + DataHListFlatCxt, + DataRecordCxt, + TypeRepsList(..), + + -- ** less likely to be used + RecordLabelsStr(..), + GfoldlK(..), + GunfoldK(..), + HListFlat(..), + TypeablePolyK, + ) where + +import Data.HList.FakePrelude +import Data.HList.HList +import Data.HList.Record +import Data.HList.Variant +import Data.Data +import Data.HList.TIC +import Data.HList.TIP + +-- for Typeable '[] and Typeable '(:) with ghc-7.6 +import Data.Orphans () + +#if OLD_TYPEABLE +import Data.List +#endif + +import Unsafe.Coerce + + +deriving instance Typeable (HList '[]) => Data (HList '[]) +deriving instance + (Data x, + Data (HList xs), + TypeablePolyK (x ': xs), -- for new typeable + Typeable (HList (x ': xs) -- for old typeable + )) => Data (HList (x ': xs)) + +deriving instance + (TypeablePolyK xs, + Typeable (HList xs), + Data (HList xs)) => Data (TIP xs) +deriving instance + (TypeablePolyK xs, + Typeable (Variant xs), + Data (Variant xs)) => Data (TIC xs) + +-- | this data type only exists to have Data instance +newtype HListFlat a = HListFlat (HList a) + +type DataHListFlatCxt na g a = ( + g ~ FoldRArrow a (HList a), + HBuild' '[] g, + Typeable (HListFlat a), + TypeablePolyK a, + HFoldl (GfoldlK C) (C g) a (C (HList a)), + + HFoldr + (GunfoldK C) + (C g) + (HReplicateR na ()) + (C (HList a)), + + HLengthEq a na, + HReplicate na ()) + + +-- | ghc-8.0.2 can't work out the type g, +-- in the 2nd argument of gfoldl. ghc <= 7.10 +-- don't need it. +-- +-- in `instance Data (HListFlat '[a,b,c])` +-- +-- > g ~ (a -> b -> c -> HList '[a,b,c]) +-- > g ~ GetG '[a,b,c] (HList '[a,b,c]) +type family FoldRArrow (xs :: [*]) (r :: *) + +type instance FoldRArrow '[] r = r +type instance FoldRArrow (x ': xs) r = x -> FoldRArrow xs r + + +instance DataHListFlatCxt na g a => Data (HListFlat a) where + gfoldl k z (HListFlat xs) = c3 $ + hFoldl + (c1 (GfoldlK k)) + (c2 (z hBuild)) + xs + where + c1 :: forall c. GfoldlK c -> GfoldlK C + c1 = unsafeCoerce + + c2 :: forall c. c g -> C g + c2 = unsafeCoerce + + c3 :: forall c. C (HList a) -> c (HListFlat a) + c3 = unsafeCoerce + + gunfold k z _ = + c3 $ withSelf $ \self -> + hFoldr + (c1 (GunfoldK k)) + (c2 (z hBuild)) + (hReplicate (hLength self) ()) + where + withSelf :: forall t c. (t -> c t) -> c t + withSelf x = x undefined + + c1 :: forall c. GunfoldK c -> GunfoldK C + c1 = unsafeCoerce + + c2 :: forall c. c g -> C g + c2 = unsafeCoerce + + c3 :: forall c. C (HList a) -> c (HListFlat a) + c3 = unsafeCoerce + + dataTypeOf _ = hListFlatDataRep + toConstr _ = hListFlatConRep + +hListFlatDataRep = mkDataType "Data.HList.HList" [hListFlatConRep] +hListFlatConRep = mkConstr hListFlatDataRep "HListFlat" [] Prefix + +type DataRecordCxt a = + (Data (HListFlat (RecordValuesR a)), + TypeablePolyK a, + TypeRepsList (Record a), + RecordValues a, + RecordLabelsStr a) + +instance DataRecordCxt a => Data (Record a) where + gfoldl k z xs = c1 (gfoldl k z (HListFlat (recordValues xs))) + where + c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a) + c1 = unsafeCoerce + + gunfold k z con = c1 (gunfold k z con) + where + -- LVPair and Record are newtypes, so this should be safe... + c1 :: forall c. c (HListFlat (RecordValuesR a)) -> c (Record a) + c1 = unsafeCoerce + + dataTypeOf x = snd (recordReps (recordLabelsStr x)) + toConstr x = fst (recordReps (recordLabelsStr x)) + + +recordReps fields = + let c = mkConstr d "Record" fields Prefix + d = mkDataType "Data.HList.Record" [c] + in (c,d) + + + +class RecordLabelsStr (xs :: [*]) where + recordLabelsStr :: Record xs -> [String] + +instance RecordLabelsStr '[] where + recordLabelsStr _ = [] +instance (RecordLabelsStr xs, + ShowLabel x) => RecordLabelsStr (Tagged x t ': xs) where + recordLabelsStr _ = showLabel (Label :: Label x) : + recordLabelsStr (undefined :: Record xs) + +{- | + +This alternative option works too, but for whatever reason +splitting up recordLabelsStr and recordLabels into two functions +means that a type annotation is needed on the 3, which is not +necessary with the above recordLabelsStr (ghc-7.6.3) + +> recordLabelsStr2 (recordLabels (((Label :: Label "x") .=. 3 .*. emptyRecord ))) + +-} +class RecordLabelsStr2 (xs :: [k]) where + recordLabelsStr2 :: proxy xs -> [String] + +instance RecordLabelsStr2 '[] where + recordLabelsStr2 _ = [] +instance (RecordLabelsStr2 xs, + ShowLabel x) => RecordLabelsStr2 (x ': xs) where + recordLabelsStr2 _ = showLabel (Label :: Label x) : + recordLabelsStr2 (Proxy :: Proxy xs) + + +-- | use only with @instance Data (HList a)@. This is because the HFoldl +-- context cannot be written for a @c@ that only appears in the method +-- 'gfoldl'. +data C a + +class TypeRepsList a where + typeRepsList :: a -> [TypeRep] + + +instance (TypeRepsList (HList xs)) => TypeRepsList (Record xs) where + typeRepsList (Record xs) = typeRepsList xs + +instance (TypeRepsList (HList xs), Typeable x) => TypeRepsList (HList (x ': xs)) where + typeRepsList (~(x `HCons` xs)) + = typeOf x : typeRepsList xs + +instance TypeRepsList (HList '[]) where + typeRepsList _ = [] + + + +-- | wraps up the first argument to 'gfoldl' +data GfoldlK c where + GfoldlK :: (forall d b . Data d => c (d -> b) -> d -> c b) -> GfoldlK c + +instance (Data d, (c (d -> b), d) ~ x, c b ~ y) => + ApplyAB (GfoldlK c) x y where + applyAB (GfoldlK f) (u,v) = f u v + + +data GunfoldK c where + GunfoldK :: (forall b r. Data b => c (b -> r) -> c r) -> GunfoldK c + +instance (Data b, x ~ (t, c (b -> r)), y ~ c r) => + ApplyAB (GunfoldK c) x y where + applyAB (GunfoldK f) (_, u) = f u diff --git a/hlist/Data/HList/Dredge.hs b/hlist/Data/HList/Dredge.hs new file mode 100644 --- /dev/null +++ b/hlist/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/hlist/Data/HList/FakePrelude.hs b/hlist/Data/HList/FakePrelude.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/FakePrelude.hs @@ -0,0 +1,831 @@ +{-# LANGUAGE CPP #-} + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Some very basic technology for faking dependent types in Haskell. +-} + +module Data.HList.FakePrelude + (module Data.HList.FakePrelude, + -- * re-exports + module Data.Proxy, + module Data.Tagged, + Monoid(..), + Any) where + +import Data.Proxy +import Data.Tagged +import GHC.Exts (Constraint,Any) +import GHC.TypeLits +#if __GLASGOW_HASKELL__ >= 800 +import qualified GHC.TypeLits as Data.HList.FakePrelude (ErrorMessage((:$$:), (:<>:))) -- XXX check this works? +#endif +#if __GLASGOW_HASKELL__ <= 906 +import Control.Applicative +#endif +#if NEW_TYPE_EQ +import Data.Type.Equality (type (==)) +#endif + +#if !OLD_TYPEABLE +import Data.Typeable +#endif + +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid (Monoid(..)) +#endif + + +-- -------------------------------------------------------------------------- +-- * A heterogeneous apply operator + +-- | simpler/weaker version where type information only propagates forward +-- with this one. 'applyAB' defined below, is more complicated / verbose to define, +-- but it offers better type inference. Most uses have been converted to +-- 'applyAB', so there is not much that can be done with 'Apply'. +class Apply f a where + type ApplyR f a :: * + apply :: f -> a -> ApplyR f a + +{- $note + + Polymorphic functions are not first-class in haskell. An example of this + is: + + > f op = (op (1 :: Double), op (1 :: Int)) + + [@RankNTypes@] + + One solution is to enable `-XRankNTypes` and then write a type + signature which might be `f :: (forall a. Num a => a -> a)`. This + does not work in the context of HList, since we want to use functions + that do not necessarily fall into the pattern of (forall a. c a => a -> a). + + [@MultipleArguments@] + + Another solution is to rewrite @op@ to look like + + > f op1 op2 = (op1 (1:: Double), op2 (1 :: Int)) + + In some sense this approach works (see HZip), but the result + is constrained to as many function applications as you are willing to + write (ex. a function that works for records of six entries would + look like @hBuild f f f f f f@). + + + [@Defunctionalization@] + + Therefore the selected solution is to write an instance of 'ApplyAB' for a data + type that takes the place of the original function. In other words, + + > data Fn = Fn + > instance ApplyAB Fn a b where applyAB Fn a = actual_fn a + + Normally you would have been able to pass around the definition actual_fn. + + [@Type inference / Local functional dependencies@] + + Note that @class ApplyAB@ has three parameters and no functional dependencies. + Instances should be written in the style: + + > instance (int ~ Int, double ~ Double) => ApplyAB Fn int double + > where applyAB _ = fromIntegral + + rather than the more natural + + > instance ApplyAB Fn Int Double + + The first instance allows types to be inferred as if we had + @class ApplyAB a b c | a -> b c@, while the second instance + only matches if ghc already knows that it needs + @ApplyAB Fn Int Double@. Since @applyAB Fn :: Int -> Double@ + has a monomorphic type, this trimmed down example does not + really make sense because @applyAB (fromIntegral :: Int -> Double)@ + is exactly the same. Nontheless, the other uses of @ApplyAB@ + follow this pattern, and the benefits are seen when the type of + @applyAB Fn@ has at least one type variable. + + Additional explanation can be found + in + + + [@AmbiguousTypes@] + + Note that ghc only allows AllowAmbiguousTypes when a type + signature is provided. Thus expressions such as: + + > data AddJust = AddJust + > instance (y ~ Maybe x) => ApplyAB AddJust x y where + > applyAB _ x = Just x + > + > twoJustsBad = hMap AddJust . hMap AddJust -- ambiguous type + + Are not accepted without a type signature that references the + intermediate \"b\": + + > twoJusts :: forall r a b c. (HMapCxt r AddJust a b, HMapCxt r AddJust b c) => + > r a -> r c + > twoJusts a = hMap AddJust (hMap AddJust a :: r b) + + An apply class with functional dependencies + + > class ApplyAB' f a b | f a -> b, f b -> a + + Or with equivalent type families + + > class (GetB f a ~ b, GetA f b ~ a) => ApplyAB' f a b + + would not require an annotation for @twoJusts@. However, + not all instances of ApplyAB will satisfy those functional + dependencies, and thus the number of classes would proliferate. + Furthermore, inference does not have to be in one direction + only, as the example of 'Data.HList.HList.HMap' shows. + +-} + +-- | No constraints on result and argument types +class ApplyAB f a b where + applyAB :: f -> a -> b + + +{- $fun + + 'Fun' can be used instead of writing a new instance of + 'ApplyAB'. Refer to the definition/source for the the most + concise explanation. A more wordy explanation is given below: + + A type signature needs to be provided on 'Fun' to make it work. + Depending on the kind of the parameters to 'Fun', a number of + different results happen. + + + [@ex1@] + + A list of kind @[* -> Constraint]@ produces those + constraints on the argument type: + + >>> :set -XDataKinds + >>> let plus1f x = if x < 5 then x+1 else 5 + >>> let plus1 = Fun plus1f :: Fun '[Num, Ord] '() + >>> :t applyAB plus1 + applyAB plus1 :: (Num b, Ord b) => b -> b + + >>> let xs = [1 .. 8] + >>> map (applyAB plus1) xs == map plus1f xs + True + + Also note the use of @'()@ to signal that the result + type is the same as the argument type. + + + A single constraint can also be supplied: + + >>> let succ1 = Fun succ :: Fun Enum '() + >>> :t applyAB succ1 + applyAB succ1 :: Enum b => b -> b + + + >>> let just = Fun Just :: Fun '[] Maybe + >>> :t applyAB just + applyAB just :: a -> Maybe a + + +-} +data Fun (cxt :: k1) (getb :: k2) + = Fun (forall a. FunCxt cxt a => a -> FunApp getb a) + +{- | see 'Fun'. The only difference here is that the argument +type is calculated from the result type. + + >>> let rd = Fun' read :: Fun' Read String + >>> :t applyAB rd + applyAB rd :: Read b => [Char] -> b + + >>> let fromJust' = Fun' (\(Just a) -> a) :: Fun' '[] Maybe + >>> :t applyAB fromJust' + applyAB fromJust' :: Maybe b -> b + +Note this use of Fun' means we don't have to get the b out of @Maybe b@, + + +-} +data Fun' (cxt :: k1) (geta :: k2) + = Fun' (forall b. FunCxt cxt b => FunApp geta b -> b) + + +type family FunApp (fns :: k) a + +type instance FunApp (fn :: *) a = fn +type instance FunApp (fn :: * -> *) a = fn a +type instance FunApp (fn :: ()) a = a + +type family FunCxt (cxts :: k) a :: Constraint +type instance FunCxt (x ': xs) a = (x a, FunCxt xs a) +type instance FunCxt (cxt :: * -> Constraint) a = cxt a +type instance FunCxt '[] a = () +-- | should there be so many ways to write no constraint? +type instance FunCxt (cxt :: ()) a = () +type instance FunCxt (cxt :: *) a = (cxt ~ a) + +instance (FunCxt cxt a, FunApp getb a ~ b) => ApplyAB (Fun cxt getb) a b where + applyAB (Fun f) x = f x + +instance (FunCxt cxt b, FunApp geta b ~ a) => ApplyAB (Fun' cxt geta) a b where + applyAB (Fun' f) x = f x + + + + +-- ** Simple useful instances of Apply +-- | note this function will only be available at a single type +-- (that is, @hMap succ@ will only work on 'HList' that contain +-- only one type) +instance (x' ~ x, y' ~ y) => ApplyAB (x' -> y') x y where + applyAB f x = f x + + + +{- | print. An alternative implementation could be: + +>>> let hPrint = Fun print :: Fun Show (IO ()) + +This produces: + +>>> :t applyAB hPrint +applyAB hPrint :: Show a => a -> IO () + +-} +data HPrint = HPrint + +instance (io ~ IO (), Show x) => ApplyAB HPrint x io where + applyAB _ x = print x + + + +{- | read + +>>> applyAB HRead "5.0" :: Double +5.0 + +-} +data HRead = HRead +instance (String ~ string, Read a) => ApplyAB HRead string a where + applyAB _ x = read x + +-- | show +data HShow = HShow +instance (String ~ string, Show a) => ApplyAB HShow a string where + applyAB _ x = show x + + + + + +{- | Compose two instances of 'ApplyAB' + +>>> applyAB (HComp HRead HShow) (5::Double) :: Double +5.0 + +-} +data HComp g f = HComp g f -- ^ @g . f@ + +instance (ApplyAB f a b, ApplyAB g b c) => ApplyAB (HComp g f) a c where + applyAB ~(HComp g f) x = applyAB g (applyAB f x :: b) + + +{- | @app Comp (f,g) = g . f@. Works like: + +>>> applyAB Comp (succ, pred) 'a' +'a' + +>>> applyAB Comp (toEnum :: Int -> Char, fromEnum) 10 +10 + +Note that defaulting will sometimes give you the wrong thing + +> used to work (with associated types calculating result/argument types) +> >>> applyAB Comp (fromEnum, toEnum) 'a' +> *** Exception: Prelude.Enum.().toEnum: bad argument + +-} +data Comp = Comp + +instance (y ~ y', fg ~ (x -> y, y' -> z), r ~ (x -> z)) => ApplyAB Comp fg r + where + applyAB _ (f,g) = g . f + +-- | (\(a,b) -> f a >> b) +newtype HSeq x = HSeq x +instance (Monad m, ApplyAB f x fx, fx ~ m (), pair ~ (x,m ()), + ApplyAB f x (m ()) ) => ApplyAB (HSeq f) pair fx where + applyAB (HSeq f) (x,c) = do asVoid (applyAB f x); c + where asVoid :: m () -> m () + asVoid t = t + + + +-- | @HJust ()@ is a placeholder for a function that applies the 'HJust' constructor +instance hJustA ~ HJust a => ApplyAB (HJust t) a hJustA where + applyAB _ a = HJust a + + +-- | 'flip' +data HFlip = HFlip + +instance (f1 ~ (a -> b -> c), f2 ~ (b -> a -> c)) => ApplyAB HFlip f1 f2 where + applyAB _ = flip + + +-- | 'fmap' +newtype HFmap f = HFmap f + +instance (x ~ t a, + y ~ t b, + Functor t, + ApplyAB f a b) => + ApplyAB (HFmap f) x y where + applyAB (HFmap f) = fmap (applyAB f) + + +-- | 'liftA2' +newtype LiftA2 f = LiftA2 f + +instance (ApplyAB f (x,y) z, + mz ~ m z, + mxy ~ (m x, m y), + Applicative m) => ApplyAB (LiftA2 f) mxy mz where + applyAB (LiftA2 f) xy = liftA2 (curry (applyAB f)) `uncurry` xy + + +-- | 'untag' +data HUntag = HUntag +instance (Tagged t x ~ tx) => ApplyAB HUntag tx x where + applyAB _ (Tagged x) = x + + +-- -------------------------------------------------------------------------- +-- * Proxy +-- + +-- $note see "Data.Proxy" + +-- | A special 'Proxy' for record labels, polykinded +data Label l = Label + +labelToProxy :: Label l -> Proxy l +labelToProxy _ = Proxy + +class ShowLabel l where + showLabel :: Label l -> String + + +-- -------------------------------------------------------------------------- + +-- * Booleans + +{- $boolNote + +GHC already lifts booleans, defined as + +> data Bool = True | False + +to types: Bool becomes kind and True and False (also denoted by +'True and 'False) become nullary type constructors. + +The above line is equivalent to + +> data HTrue +> data HFalse + +> class HBool x +> instance HBool HTrue +> instance HBool HFalse + +-} + +-- ** Value-level proxies +hTrue :: Proxy True ; hTrue = Proxy +hFalse :: Proxy False; hFalse = Proxy + + +-- ** Conjunction + +type family HAnd (t1 :: Bool) (t2 :: Bool) :: Bool +type instance HAnd False t = False +type instance HAnd True t = t + +-- | `demote' to values +hAnd :: Proxy t1 -> Proxy t2 -> Proxy (HAnd t1 t2) +hAnd _ _ = Proxy + + +-- ** Disjunction + +type family HOr (t1 :: Bool) (t2 :: Bool) :: Bool +type instance HOr False t = t +type instance HOr True t = True + +-- | `demote' to values +hOr :: Proxy t1 -> Proxy t2 -> Proxy (HOr t1 t2) +hOr _ _ = Proxy + +{- $boolHistoricalNote + +Compare with the original code based on functional dependencies: + +> class (HBool t, HBool t', HBool t'') => HOr t t' t'' | t t' -> t'' +> where +> hOr :: t -> t' -> t'' + +> instance HOr HFalse HFalse HFalse +> where +> hOr _ _ = hFalse + +> instance HOr HTrue HFalse HTrue +> where +> hOr _ _ = hTrue + +> instance HOr HFalse HTrue HTrue +> where +> hOr _ _ = hTrue + +> instance HOr HTrue HTrue HTrue +> where +> hOr _ _ = hTrue +-} + +type family HNot (x :: Bool) :: Bool +type instance HNot True = False +type instance HNot False = True + +-- | as compared with 'HNot' this version is injective +class HNotFD (b :: Bool) (nb :: Bool) | b -> nb, nb -> b +instance HNotFD True False +instance HNotFD False True + +hNot :: HNotFD a notA => Proxy a -> Proxy notA +hNot _ = Proxy + + +class HCond (t :: Bool) x y z | t x y -> z + where + hCond :: Proxy t -> x -> y -> z + +instance HCond False x y y + where + hCond _ _ y = y + +instance HCond True x y x + where + hCond _ x _ = x + + +-- ** Boolean equivalence + +type family HBoolEQ (t1 :: Bool) (t2 :: Bool) :: Bool +type instance HBoolEQ False False = True +type instance HBoolEQ False True = False +type instance HBoolEQ True False = False +type instance HBoolEQ True True = True + +-- We could define all kinds of further Boolean operations. +-- We omit everything what's not needed for the code in the paper. + +-- -------------------------------------------------------------------------- + +-- * Naturals + +-- | The data type to be lifted to the type level +data HNat = HZero | HSucc HNat + + +hZero :: Proxy HZero; hZero = Proxy +hSucc :: Proxy (n :: HNat) -> Proxy (HSucc n); hSucc _ = Proxy +hPred :: Proxy (HSucc n) -> Proxy n; hPred _ = Proxy + +class HNat2Integral (n::HNat) where + hNat2Integral :: Integral i => Proxy n -> i + +type family HNat2Nat (n :: HNat) :: Nat +type instance HNat2Nat HZero = 0 +type instance HNat2Nat (HSucc n) = 1 + HNat2Nat n + +#if MIN_VERSION_base(4,7,0) +{- Instead convert HNat to GHC.TypeLits.'Nat' with 'HNat2Nat' and use functions +from that module to produce the 'Integer' -} +instance KnownNat (HNat2Nat n) => HNat2Integral n where + hNat2Integral _ = fromIntegral (natVal (Proxy :: Proxy (HNat2Nat n))) +#else +{- doesn't work: gives "No instance for (SingI Nat (1 + (1 + 0)))" +instance SingI (HNat2Nat n) => HNat2Integral n where + hNat2Integral _ = fromIntegral (fromSing (sing :: Sing (HNat2Nat n))) +-} + +-- | a slow (at runtime) implementation for ghc 7.6: +instance HNat2Integral HZero where + hNat2Integral _ = 0 + +instance HNat2Integral n => HNat2Integral (HSucc n) where + hNat2Integral n = hNat2Integral (hPred n) + 1 +#endif + + +class HNats2Integrals (ns :: [HNat]) where + hNats2Integrals :: Integral i => Proxy ns -> [i] + +instance HNats2Integrals '[] where + hNats2Integrals _ = [] + +instance (HNats2Integrals ns, + HNat2Integral n) + => HNats2Integrals (n ': ns) where + hNats2Integrals _ = hNat2Integral (Proxy :: Proxy n) : + hNats2Integrals (Proxy :: Proxy ns) + + + +-- | Equality on natural numbers +-- (eventually to be subsumed by the universal polykinded HEq) +type family HNatEq (t1 :: HNat) (t2 :: HNat) :: Bool +type instance HNatEq HZero HZero = True +type instance HNatEq HZero (HSucc n) = False +type instance HNatEq (HSucc n) HZero = False +type instance HNatEq (HSucc n) (HSucc n') = HNatEq n n' + + +-- | Less than + +type family HLt (x :: HNat) (y :: HNat) :: Bool + +type instance HLt HZero HZero = False +type instance HLt HZero (HSucc n) = True +type instance HLt (HSucc n) HZero = False +type instance HLt (HSucc n) (HSucc n') = HLt n n' + +hLt :: Proxy x -> Proxy y -> Proxy (HLt x y) +hLt _ _ = Proxy + + +-- | Less than or equal to +type family HLe (x :: HNat) (y :: HNat) :: Bool + +type instance HLe HZero HZero = True +type instance HLe (HSucc x) y = HLt x y + +hLe :: Proxy x -> Proxy y -> Proxy (HLe x y) +hLe _ _ = Proxy + +-- | @HDiv2 x@ behaves like @x `div` 2@ +type family HDiv2 (x :: HNat) :: HNat +type instance HDiv2 HZero = HZero +type instance HDiv2 (HSucc HZero) = HZero +type instance HDiv2 (HSucc (HSucc a)) = HSucc (HDiv2 a) + + + +-- -------------------------------------------------------------------------- +-- * Maybies +-- $maybiesNote We cannot use lifted Maybe since the latter are not populated + +data HNothing = HNothing deriving Show +newtype HJust x = HJust x deriving Show + + +-- -------------------------------------------------------------------------- + +-- * Polykinded Equality for types +-- | We have to use Functional dependencies for now, +-- for the sake of the generic equality. +class HEq (x :: k) (y :: k) (b :: Bool) | x y -> b + +-- | Equality for types that may have different kinds. This definition +-- allows operations on @Record [Tagged \"x\" a, Tagged 2 b]@ to work +-- as expected. +type HEqK (x :: k1) (y :: k2) (b :: Bool) = HEq (Proxy x) (Proxy y) b + +#if NEW_TYPE_EQ +-- | Uses @(==) :: * -> * -> Bool@ because +-- there is no polykinded instance of (==), +-- since that one overlaps "more productive" +-- instances that pattern match on types. +instance ((Proxy x == Proxy y) ~ b) => HEq x y b +#endif + +hEq :: HEq x y b => x -> y -> Proxy b +hEq _ _ = Proxy + + +-- | this class generalizes HEq by allowing the choice of @f@ to allow +-- equating only part of x and y +class HEqByFn f => HEqBy (f :: t) (x :: k) (y :: k) (b :: Bool) | f x y -> b + + + + +-- | Every instance of this class should have an instance of 'HEqBy' +class HEqByFn f + +-- * Arity + +type Arity f n = (ArityFwd f n, ArityRev f n) + +-- | calculate the number of arguments a function can take +class ArityFwd (f :: *) (n :: HNat) | f -> n + + +-- | given the number of arguments a function can take, make sure +-- the function type actually matches +class ArityRev (f :: *) (n :: HNat) -- n -> f -- if we had -XDysfunctionalDependencies + +instance ArityRev f HZero +instance (xf ~ (x -> f), ArityRev f n) => ArityRev xf (HSucc n) + + +-- -------------------------------------------------------------------------- + +-- * Staged equality +-- | +-- +-- * Establish type equality statically +-- +-- * Establish remaining value-level equality dynamically +-- +-- removed: use typeable + + +-- -------------------------------------------------------------------------- +-- * Type-safe cast -- no longer need. We use a a ~ b + + +-- * Cast + +-- | Named after 'Data.Typeable.cast', which behaves the same at runtime. +-- One difference is that there is a HCast instance for every type, while +-- 'Typeable' instances can be missing sometimes. + +class HCast x y where + hCast :: x -> Maybe y + +instance (HEq x y b, HCast1 b x y) => HCast x y where + hCast = hCast1 (Proxy :: Proxy b) + +-- | helper for 'HCast' +class HCast1 (b :: Bool) x y where + hCast1 :: Proxy b -> x -> Maybe y + +instance (x ~ y) => HCast1 True x y where + hCast1 _ x = Just x + +instance HCast1 False x y where + hCast1 _ _ = Nothing + + + + +-- -------------------------------------------------------------------------- + +-- * Error messages + +{- | A class without instances for explicit failure. + +Note that with ghc>=8.0, `x :: TypeError` which is formatted properly. +Otherwise `x` is made of nested (left-associated) promoted tuples. +For example: + +> (x ~ '( '( '("the", Int), "is wrong") ) ) :: ((,) Symbol *, Symbol) + +Therefore code that works across ghc-7.6 through ghc-8.0 needs to +use ErrText, ErrShowType, :<>:, :$$: to construct the type x. -} +class Fail (x :: k) + +#if __GLASGOW_HASKELL__ >= 800 +-- | use the alias ErrText to prevent conflicts with Data.Text +-- +-- GHC.TypeLits.:<>: and GHC.TypeLits.:$$: are re-exported +type ErrText x = GHC.TypeLits.Text x +type ErrShowType x = GHC.TypeLits.ShowType x + +-- type Fail = TypeError -- another option +instance TypeError x => Fail x +#else + +type ErrText x = x +type ErrShowType x = x +type x :<>: y = '(x,y) +type x :$$: y = '(x,y) +infixl 6 :<>: +infixl 5 :$$: +#endif + +-- ** Error messages used elsewhere +type FieldNotFound key collection = ErrText "key" :<>: ErrShowType key + :$$: ErrText "could not be found in" :<>: ErrShowType collection + +type ExcessFieldFound key collection = ErrText "found field" :<>: ErrShowType key + :$$: ErrText "when it should be absent from" :<>: ErrShowType collection + +type HNatIndexTooLarge (nat :: HNat) (r :: [k] -> *) (xs :: [k]) = + ErrText "0-based index" :<>: ErrShowType (HNat2Nat nat) :<>: + ErrText "is too large for collection" + :$$: ErrShowType (r xs) + -- :$$: ErrText "(length: " :<>: ErrShowType (HNat2Nat (HLength collection)) :<>: ErrText " )" + -- Data.HList.HList.HLength isn't available here + +type ExtraField x = ErrText "extra field" :<>: ErrShowType x + + +#if OLD_TYPEABLE +type TypeablePolyK a = (() :: Constraint) +#else +type TypeablePolyK (a :: k) = Typeable a +#endif + +-- * Constraining Lists +-- ** Length + +-- | Ensure two lists have the same length. We do case analysis on the +-- first one (hence the type must be known to the type checker). +-- In contrast, the second list may be a type variable. +class SameLength' (es1 :: [k]) (es2 :: [m]) +instance (es2 ~ '[]) => SameLength' '[] es2 +instance (SameLength' xs ys, es2 ~ (y ': ys)) => SameLength' (x ': xs) es2 + +{- | symmetrical version of 'SameLength''. Written as a class instead of + + > type SameLength a b = (SameLength' a b, SameLength' b a) + +since ghc expands type synonyms, but not classes (and it seems to have the same +result) + +-} +class (SameLength' x y, SameLength' y x) => + SameLength (x :: [k]) (y :: [m]) where + + {- | @SameLength x y => Equality (r x) (q y) (r x) (q y)@ + + used like 'Control.Lens.simple', except it restricts + the type-level lists involved to have the same length, + without fixing the type of container or the elements + in the list. + -} + sameLength :: r x `p` f (q y) -> r x `p` f (q y) + sameLength = id + +-- | 'asTypeOf' +asLengthOf :: SameLength x y => r x -> s y -> r x +asLengthOf = const + + +instance (SameLength' x y, SameLength' y x) => SameLength x y + +type family SameLengths (xs :: [[k]]) :: Constraint +type instance SameLengths (x ': y ': ys) = (SameLength x y, SameLengths (y ': ys)) +type instance SameLengths '[] = () +type instance SameLengths '[x] = () + +-- ** Labels + +class SameLabels (x :: k) (y :: m) + +{- | @sameLabels@ constrains the type of an optic, such that the labels + (@t@ in @Tagged t a@) are the same. @x@ or @y@ may have more elements + than the other, in which case the elements at the end + of the longer list do not have their labels constrained. + + see also 'sameLength' +-} +sameLabels :: SameLabels x y => p (r x) (f (q y)) -> p (r x) (f (q y)) +sameLabels = id + +-- instances for [*] kind +instance SameLabels '[] '[] +instance SameLabels '[] (x ': xs) +instance SameLabels (x ': xs) '[] +instance (SameLabels x y, SameLabels xs ys) => + SameLabels (x ': xs) (y ': ys) + + +instance (Label t ~ Label t') => SameLabels (Label t) (Tagged t' a) +instance (Label t ~ Label t') => SameLabels (Label t) (Label t') +instance (Label t ~ Label t') => SameLabels (Label t) (t' :: Symbol) + +instance SameLabels (Label t) s => SameLabels (t :: Symbol) s +instance SameLabels (Label t) s => SameLabels (Tagged t a) s + +-- ** A list has only Tagged values + +-- | The 'Record', 'Variant', 'TIP', 'TIC' type constructors only make +-- sense when they are applied to an instance of this class +class HAllTaggedLV (ps :: [*]) +instance HAllTaggedLV '[] +instance (HAllTaggedLV xs, x ~ Tagged t v) => HAllTaggedLV (x ': xs) + + +-- | see Data.HList.Record.'zipTagged' +type family ZipTagged (ts :: [k]) (vs :: [*]) :: [*] +type instance ZipTagged (Label t ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs +type instance ZipTagged ((t :: Symbol) ': ts) (v ': vs) = Tagged t v ': ZipTagged ts vs +type instance ZipTagged '[] '[] = '[] diff --git a/hlist/Data/HList/HArray.hs b/hlist/Data/HList/HArray.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HArray.hs @@ -0,0 +1,225 @@ + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Array-like access to HLists. + -} + +module Data.HList.HArray where + +import Data.HList.FakePrelude +import Data.HList.HList + + +-- -------------------------------------------------------------------------- +-- * Lookup + +class HLookupByHNat (n :: HNat) (l :: [*]) where + type HLookupByHNatR (n :: HNat) (l :: [*]) :: * + hLookupByHNat :: Proxy n -> HList l -> HLookupByHNatR n l + +instance HLookupByHNat HZero (e ': l) where + type HLookupByHNatR HZero (e ': l) = e + hLookupByHNat _ (HCons e _) = e + +instance HLookupByHNat n l => HLookupByHNat (HSucc n) (e ': l) where + type HLookupByHNatR (HSucc n) (e ': l) = HLookupByHNatR n l + hLookupByHNat n (HCons _ l) = hLookupByHNat (hPred n) l + + +-- -------------------------------------------------------------------------- +-- * Delete + +class HDeleteAtHNat (n :: HNat) (l :: [*]) where + type HDeleteAtHNatR (n :: HNat) (l :: [*]) :: [*] + hDeleteAtHNat :: Proxy n -> HList l -> HList (HDeleteAtHNatR n l) + +instance HDeleteAtHNat HZero (e ': l) where + type HDeleteAtHNatR HZero (e ': l) = l + hDeleteAtHNat _ (HCons _ l) = l + +instance HDeleteAtHNat n l => HDeleteAtHNat (HSucc n) (e ': l) where + type HDeleteAtHNatR (HSucc n) (e ': l) = e ': (HDeleteAtHNatR n l) + hDeleteAtHNat n (HCons e l) = HCons e (hDeleteAtHNat (hPred n) l) + + +-- -------------------------------------------------------------------------- +-- * Update +class HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where + hUpdateAtHNat :: Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) + +instance HUpdateAtHNat' n e l l => HUpdateAtHNat n e l where + hUpdateAtHNat = hUpdateAtHNat' (Proxy :: Proxy l) + +class HUpdateAtHNat' (n :: HNat) e (l :: [*]) (l0 :: [*]) where + type HUpdateAtHNatR (n :: HNat) e (l :: [*]) :: [*] + hUpdateAtHNat' :: Proxy l0 -> Proxy n -> e -> HList l -> HList (HUpdateAtHNatR n e l) + +instance HUpdateAtHNat' HZero e1 (e ': l) l0 where + type HUpdateAtHNatR HZero e1 (e ': l) = e1 ': l + hUpdateAtHNat' _ _ e1 (HCons _ l) = HCons e1 l + +instance HUpdateAtHNat' n e1 l l0 => HUpdateAtHNat' (HSucc n) e1 (e ': l) l0 where + type HUpdateAtHNatR (HSucc n) e1 (e ': l) = e ': (HUpdateAtHNatR n e1 l) + hUpdateAtHNat' l0 n e1 (HCons e l) = HCons e (hUpdateAtHNat' l0 (hPred n) e1 l) + +instance Fail (HNatIndexTooLarge n HList l0) => HUpdateAtHNat' n e1 '[] l0 where + type HUpdateAtHNatR n e1 '[] = '[] + hUpdateAtHNat' _ _ _ = error "Data.HList.HArray.HUpdateAtHNat: Fail must have no instances" + +-- -------------------------------------------------------------------------- +-- * Projection + +-- One way of implementing it: + +hProjectByHNats' ns l = hMap (FHLookupByHNat l) ns + +newtype FHLookupByHNat (l :: [*]) = FHLookupByHNat (HList l) + +instance HLookupByHNat n l => + Apply (FHLookupByHNat l) (Proxy (n :: HNat)) where + type ApplyR (FHLookupByHNat l) (Proxy n) = HLookupByHNatR n l + apply (FHLookupByHNat l) n = hLookupByHNat n l + +-- The drawback is that the list ns must be a constructed value. +-- We cannot lazily pattern-match on GADTs. Moreover, there are +-- repeated traversals of the HList l at run-time. + +-- Here is a more optimal version with a better separation of +-- compile-time and run-time computation. +-- The list of labels to project is type-level only. +-- We treat this list of labels as a set -- that is, we will +-- ignore duplicates. +-- We traverse the HList l only once. The lookup in the list of +-- indices is compile-time only. +-- (In contrast, hProjectByHNats' does not ignore duplicates). +-- We unify hProjectByHNats and hProjectAwayByHNats in one +-- function, distinguished by the sel :: Bool in +-- FHUProj below. The operation hProjectByHNats corresponds +-- to sel = True (that is, elements of l whose indices are found in +-- ns are to be included in the result), whereas hProjectByHNats +-- corresponds to set = False. + +hProjectByHNats (_ :: Proxy (ns :: [HNat])) l = + hUnfold (FHUProj :: FHUProj True ns) (l,hZero) + +data FHUProj (sel :: Bool) (ns :: [HNat]) = FHUProj + +instance Apply (FHUProj sel ns) (HList '[],n) where + type ApplyR (FHUProj sel ns) (HList '[],n) = HNothing + apply _ _ = HNothing + +instance (ch ~ Proxy (HBoolEQ sel (KMember n ns)), + Apply (ch, FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat))) => + Apply (FHUProj sel ns) (HList (e ': l),Proxy (n :: HNat)) where + type ApplyR (FHUProj sel ns) (HList (e ': l),Proxy n) = + ApplyR (Proxy (HBoolEQ sel (KMember n ns)), FHUProj sel ns) + (HList (e ': l),Proxy n) + apply fn s = apply (Proxy::ch,fn) s + +instance Apply (Proxy True, FHUProj sel ns) + (HList (e ': l),Proxy (n::HNat)) where + type ApplyR (Proxy True, FHUProj sel ns) (HList (e ': l),Proxy n) = + (HJust (e, (HList l,Proxy (HSucc n)))) + apply _ (HCons e l,n) = (HJust (e,(l,hSucc n))) + +instance (Apply (FHUProj sel ns) (HList l, Proxy (HSucc n))) => + Apply (Proxy False, FHUProj sel ns) + (HList (e ': l),Proxy (n::HNat)) where + type ApplyR (Proxy False, FHUProj sel ns) (HList (e ': l),Proxy n) = + ApplyR (FHUProj sel ns) (HList l, Proxy (HSucc n)) + apply (_,fn) (HCons _ l,n) = apply fn (l,hSucc n) + + +-- lifted member on naturals +type family KMember (n :: HNat) (ns :: [HNat]) :: Bool +type instance KMember n '[] = False +type instance KMember n (n1 ': l) = HOr (HNatEq n n1) (KMember n l) + +-- Useful abbreviations for complex types (which are inferred) +type HProjectByHNatsR (ns :: [HNat]) (l :: [*]) = + HUnfold (FHUProj True ns) (HList l, Proxy 'HZero) + +type HProjectByHNatsCtx ns l = + (Apply (FHUProj True ns) (HList l, Proxy 'HZero), + HUnfold' (FHUProj True ns) + (HList l, Proxy 'HZero) + ) + +-- * Complement of Projection + +-- The naive approach is repeated deletion (which is a bit subtle +-- sine we need to adjust indices) +-- Instead, we compute the complement of indices to project away +-- to obtain the indices to project to, and then use hProjectByHNats. +-- Only the latter requires run-time computation. The rest +-- are done at compile-time only. + +hProjectAwayByHNats (_ :: Proxy (ns :: [HNat])) l = + hUnfold (FHUProj :: FHUProj False ns) (l,hZero) + + +-- Useful abbreviations for complex types (which are inferred) +type HProjectAwayByHNatsR (ns :: [HNat]) (l :: [*]) = + HUnfold (FHUProj False ns) (HList l, Proxy 'HZero) + +type HProjectAwayByHNatsCtx ns l = + (Apply (FHUProj False ns) (HList l, Proxy 'HZero), + HUnfold' (FHUProj False ns) (HList l, Proxy 'HZero) + ) + +-- * Splitting +-- | Splitting an array according to indices + +-- The following is not optimal; we'll optimize later if needed + +hSplitByHNats ns l = (hProjectByHNats ns l, + hProjectAwayByHNats ns l) +{- +hSplitByHNats ns l = hSplitByHNats' ns (hFlag l) + +class HNats ns => HSplitByHNats' ns l l' l'' | ns l -> l' l'' + where + hSplitByHNats' :: ns -> l -> (l',l'') + +instance HSplit l l' l'' + => HSplitByHNats' HNil l HNil l' + where + hSplitByHNats' HNil l = (HNil,l') + where + (l',_) = hSplit l + +instance ( HLookupByHNat n l (e,b) + , HUpdateAtHNat n (e,HFalse) l l''' + , HSplitByHNats' ns l''' l' l'' + ) + => HSplitByHNats' (HCons n ns) l (HCons e l') l'' + where + hSplitByHNats' (HCons n ns) l = (HCons e l',l'') + where + (e,_) = hLookupByHNat n l + l''' = hUpdateAtHNat n (e,hFalse) l + (l',l'') = hSplitByHNats' ns l''' +-} + + +{- + +-- -------------------------------------------------------------------------- +-- * Bounded lists + +class HMaxLength l s +instance (HLength l s', HLt s' (HSucc s) HTrue) => HMaxLength l s + +class HMinLength l s +instance (HLength l s', HLt s (HSucc s') HTrue) => HMinLength l s + +class HSingleton l +instance HLength l (HSucc HZero) => HSingleton l + +hSingle :: (HSingleton l, HHead l e) => l -> e +hSingle = hHead + +-} diff --git a/hlist/Data/HList/HCurry.hs b/hlist/Data/HList/HCurry.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HCurry.hs @@ -0,0 +1,72 @@ +{- | + + Description : curry / uncurry + + Convert between functions taking HLists and functions taking many arguments + +-} +module Data.HList.HCurry where + +import Data.HList.FakePrelude +import Data.HList.HList +import Data.HList.TypeEqO () -- Arity instance + +{- | 'curry'/'uncurry' for many arguments and HLists instead of tuples + +XXX the last FD @xs -> n@ is needed to make hCompose infer the right types: +arguably it shouldn't be needed + +-} +class HLengthEq xs n => HCurry' (n :: HNat) f xs r + | f xs -> r, r xs -> f, n f -> xs, xs -> n where + hUncurry' :: Proxy n -> f -> HList xs -> r + hCurry' :: Proxy n -> (HList xs -> r) -> f + +instance HCurry' HZero b '[] b where + hUncurry' _ b _ = b + hCurry' _ f = f HNil + +instance (HCurry' n b xs r) => HCurry' (HSucc n) (x -> b) (x ': xs) r where + hUncurry' n f (HCons x xs) = hUncurry' (hPred n) (f x) xs + hCurry' n f x = hCurry' (hPred n) (f . HCons x) + +hUncurry f = hUncurry' (arityOf f) f + +-- | Note: with ghc-7.10 the Arity constraint added here does not work +-- properly with hCompose, so it is possible that other uses of 'hCurry' +-- are better served by @hCurry' Proxy@. +hCurry f = let f' = hCurry' (arityOf f') f + in f' + +{- | compose two functions that take multiple arguments. The result of the +second function is the first argument to the first function. An example is +probably clearer: + +>>> let f = hCompose (,,) (,) +>>> :t f +f :: ... -> ... -> ... -> ... -> ((..., ...), ..., ...) + +>>> f 1 2 3 4 +((1,2),3,4) + +Note: polymorphism can make it confusing as to how many parameters a function +actually takes. For example, the first two ids are @id :: (a -> b) -> (a -> b)@ in + +>>> (.) id id id 'y' +'y' + +>>> hCompose id id id 'y' +'y' + +still typechecks, but in that case @hCompose i1 i2 i3 x == i1 ((i2 i3) x)@ +has id with different types than @(.) i1 i2 i3 x == (i1 (i2 i3)) x + +Prompted by + +-} +hCompose f g = hCurry' Proxy $ \xs -> case hSplitAt Proxy xs of + (xg,xf) -> hUncurry f (hUncurry g xg `HCons` xf) + + +arityOf :: Arity f n => f -> Proxy n +arityOf _ = Proxy diff --git a/hlist/Data/HList/HList.hs b/hlist/Data/HList/HList.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HList.hs @@ -0,0 +1,1657 @@ +{-# LANGUAGE CPP #-} +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Basic declarations for typeful heterogeneous lists. + + -} + +module Data.HList.HList where + +import Data.HList.FakePrelude +import Data.HList.HListPrelude + +import Text.ParserCombinators.ReadP +import Data.List + +import LensDefs + +import Data.Array (Ix) + +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup +#endif + +-- -------------------------------------------------------------------------- +-- * Heterogeneous type sequences +{- $note + +There are three sensible ways to define HLists: + +@ +data HList (l::[*]) where + HNil :: HList '[] + HCons :: e -> HList l -> HList (e ': l) +@ + +This ensures that sequences can only be formed with Nil +and Cons. The argument to HList is a promoted lists (kind @[*]@), +which has a more attractive syntax. + + +Earlier versions of HList used an algebraic data type: + +@ +data HCons a b = HCons a b +data HNil = HNil +@ + +Disadvantages: + +* values with types like @HCons Int Double@ to be created, + which are nonsense to the functions in HList + +* some recursive functions do not need a class with the GADT. For example: + + @ + hInit :: HListGADT (x ': xs) -> HListGADT (HInit (x ': xs)) + hInit (HCons x xs@(HCons _ _)) = HCons x (hInit xs) + hInit (HCons _ HNil) = HNil + + type family HInit (xs :: [k]) :: [k] + @ + + but without the GADT, 'hInit' is written as in a class, + which complicates inferred types + + +Advantages + +* lazy pattern matches are allowed, so lazy pattern matching + on a value @undefined :: HList [a,b,c]@ can create the + spine of the list. 'hProxies' avoids the use of 'undefined', + but a slightly more complicated class context has to be written + or inferred. + +* type inference is better if you want to directly pattern match + + +* better pattern exhaustiveness checking (as of ghc-7.8) + +* standalone deriving works + +* Data.Coerce.coerce works because the parameters have role representational, + not nominal as they are for the GADT and data family. Probably the GADT/type + family actually do have a representational role: + + + + +The data family version (currently used) gives the same type constructor +@HList :: [*] -> *@ as the GADT, while pattern matching behaves +like the algebraic data type. Furthermore, nonsense values like +@HCons 1 2 :: HCons Int Int@ cannot be written with the data family. + +A variation on the data family version is + +> data instance HList '[] = HNil +> newtype instance HList (x ': xs) = HCons1 (x, HList xs) +> pattern HCons x xs = HCons1 (x, xs) + +This allows HList to have a nominal role, but on the other +hand the PatternSynonym is not supported with ghc-7.6 and +exhaustiveness checking is not as good (warnings for _ being +unmatched) + +-} + + +data family HList (l::[*]) + +data instance HList '[] = HNil +data instance HList (x ': xs) = x `HCons` HList xs + +deriving instance Eq (HList '[]) +deriving instance (Eq x, Eq (HList xs)) => Eq (HList (x ': xs)) + +deriving instance Ord (HList '[]) +deriving instance (Ord x, Ord (HList xs)) => Ord (HList (x ': xs)) + +deriving instance Ix (HList '[]) +deriving instance (Ix x, Ix (HList xs)) => Ix (HList (x ': xs)) + +deriving instance Bounded (HList '[]) +deriving instance (Bounded x, Bounded (HList xs)) => Bounded (HList (x ': xs)) + + +-- Enum cannot be derived + + +-- | creates a HList of Proxies + +class HProxiesFD (xs :: [*]) pxs | pxs -> xs -- DropProxy pxs ~ xs + , xs -> pxs -- AddProxy xs ~ pxs + where hProxies :: HList pxs + +{- Ideally we could write: + +> class DropProxy (AddProxy xs) ~ xs => HProxies xs where +> hProxies :: HList (AddProxy xs) + +See https://ghc.haskell.org/trac/ghc/ticket/10009 -} +type HProxies xs = HProxiesFD xs (AddProxy xs) + + +{- | Add 'Proxy' to a type + +>>> let x = undefined :: HList (AddProxy [Char,Int]) +>>> :t x +x :: HList '[Proxy Char, Proxy Int] + + +-} +type family AddProxy (xs :: k) :: k +type instance AddProxy '[] = '[] +type instance AddProxy (x ': xs) = AddProxy x ': AddProxy xs +type instance AddProxy (x :: *) = Proxy x + +-- | inverse of 'AddProxy' +type family DropProxy (xs :: k) :: k +type instance DropProxy (x ': xs) = DropProxy x ': DropProxy xs +type instance DropProxy '[] = '[] +type instance DropProxy (Proxy x) = x + +instance HProxiesFD '[] '[] where + hProxies = HNil + +instance (HProxiesFD xs pxs) => HProxiesFD (x ': xs) (Proxy x ': pxs) where + hProxies = Proxy `HCons` hProxies + + + +instance Show (HList '[]) where + show _ = "H[]" + +instance (Show e, Show (HList l)) => Show (HList (e ': l)) where + show (HCons x l) = + case show l of + 'H':'[':s -> "H[" ++ show x ++ (if s == "]" then s else "," ++ s) + s -> error $ "unreachable branch: " ++ show x ++ " " ++ s + +instance Read (HList '[]) where + readsPrec _ str = case stripPrefix "H[]" str of + Nothing -> [] + Just rest -> [(HNil, rest)] + +instance + (HProxies l, Read e, + HSequence ReadP (ReadP e ': readP_l) (e ': l), + HMapCxt HList ReadElement (AddProxy l) readP_l) => + Read (HList (e ': l)) where + readsPrec _ = readP_to_S $ do + _ <- string "H[" + l <- return (hProxies :: HList (AddProxy l)) + let parsers = readS_to_P reads `HCons` hMap ReadElement l + hlist <- hSequence parsers + _ <- string "]" + return hlist + + +-- similar to ReadComponent used to define instance Read Record +data ReadElement = ReadElement + +instance (y ~ ReadP x, Read x) => ApplyAB ReadElement (Proxy x) y where + applyAB ReadElement _ = do + _ <- string "," + readS_to_P reads + + +infixr 2 `HCons` + + +-- -------------------------------------------------------------------------- +-- * Basic list functions + +-- | 'head' +hHead :: HList (e ': l) -> e +hHead (HCons x _) = x + +-- | 'tail' +hTail :: HList (e ': l) -> HList l +hTail (HCons _ l) = l + +-- | 'last' +hLast xs = hHead (hReverse_ xs) + + +class HInit xs where + type HInitR xs :: [*] + hInit :: HList xs -> HList (HInitR xs) + +instance HInit '[x] where + type HInitR '[x] = '[] + hInit _ = HNil + +instance HInit (b ': c) => HInit (a ': b ': c) where + type HInitR (a ': b ': c) = a ': HInitR (b ': c) + hInit (a `HCons` bc) = a `HCons` hInit bc + + +-- | Length, but see 'HLengthEq' instead +type family HLength (x :: [k]) :: HNat +type instance HLength '[] = HZero +type instance HLength (x ': xs) = HSucc (HLength xs) + +hLength :: HLengthEq l n => HList l -> Proxy n +hLength _ = Proxy + +-- ** Append +instance HExtend e (HList l) where + type HExtendR e (HList l) = HList (e ': l) + (.*.) = HCons + +instance HAppendList l1 l2 => HAppend (HList l1) (HList l2) where + hAppend = hAppendList +type instance HAppendR (HList l1) (HList l2) = HList (HAppendListR l1 l2) + +type family HAppendListR (l1 :: [k]) (l2 :: [k]) :: [k] +type instance HAppendListR '[] l = l +type instance HAppendListR (e ': l) l' = e ': HAppendListR l l' + + +class HAppendList l1 l2 where + -- | the same as 'hAppend' + hAppendList :: HList l1 -> HList l2 -> HList (HAppendListR l1 l2) + +instance HAppendList '[] l2 where + hAppendList HNil l = l + +instance HAppendList l l' => HAppendList (x ': l) l' where + hAppendList (HCons x l) l' = HCons x (hAppendList l l') + +-- -------------------------------------------------------------------------- + +-- ** Alternative append + + +-- | 'hAppend'' below is implemented using the same idea +append' :: [a] -> [a] -> [a] +append' l l' = foldr (:) l' l + +-- | Alternative implementation of 'hAppend'. Demonstrates 'HFoldr' +hAppend' :: (HFoldr FHCons v l r) => HList l -> v -> r +hAppend' l l' = hFoldr FHCons l' l + +data FHCons = FHCons + +instance ( x ~ (e,HList l), y ~ (HList (e ': l))) => ApplyAB FHCons x y where + applyAB _ (e,l) = HCons e l + + +-- ** Historical append + +{- $ + +The original HList code is included below. In both cases +we had to program the algorithm twice, at the term and the type levels. + +[@The class HAppend@] + +> class HAppend l l' l'' | l l' -> l'' +> where +> hAppend :: l -> l' -> l'' +> + +[@The instance following the normal append@] + +> instance HList l => HAppend HNil l l +> where +> hAppend HNil l = l +> +> instance (HList l, HAppend l l' l'') +> => HAppend (HCons x l) l' (HCons x l'') +> where +> hAppend (HCons x l) l' = HCons x (hAppend l l') + +-} + +-- -------------------------------------------------------------------------- +-- * Reversing HLists + +-- Append the reversed l1 to l2 +type family HRevAppR (l1 :: [k]) (l2 :: [k]) :: [k] +type instance HRevAppR '[] l = l +type instance HRevAppR (e ': l) l' = HRevAppR l (e ': l') + + +class HRevApp l1 l2 l3 | l1 l2 -> l3 where + hRevApp :: HList l1 -> HList l2 -> HList l3 + +instance HRevApp '[] l2 l2 where + hRevApp _ l = l + +instance HRevApp l (x ': l') z => HRevApp (x ': l) l' z where + hRevApp (HCons x l) l' = hRevApp l (HCons x l') + + + +class HReverse xs sx | xs -> sx, sx -> xs where + hReverse :: HList xs -> HList sx + +instance (HRevApp xs '[] sx, + HRevApp sx '[] xs) => HReverse xs sx where + hReverse l = hRevApp l HNil + +-- | a version of 'hReverse' that does not allow the type +-- information to flow backwards +hReverse_ l = hRevApp l HNil + +-- -------------------------------------------------------------------------- + +-- +-- * A nicer notation for lists +-- + + +-- | List termination +hEnd :: HList l -> HList l +hEnd = id + +{- ^ + Note: + + [@x :: HList a@] means: @forall a. x :: HList a@ + + [@hEnd x@] means: @exists a. x :: HList a@ +-} + + +-- | Building lists + +hBuild :: (HBuild' '[] r) => r +hBuild = hBuild' HNil + +class HBuild' l r where + hBuild' :: HList l -> r + +instance HReverse l l' + => HBuild' l (HList l') where + hBuild' l = hReverse l + +instance HBuild' (a ': l) r + => HBuild' l (a->r) where + hBuild' l x = hBuild' (HCons x l) + +-- ** examples +{- $examplesNote + +The classes above allow the third (shortest) way to make a list +(containing a,b,c) in this case + +> list = a `HCons` b `HCons` c `HCons` HNil +> list = a .*. b .*. c .*. HNil +> list = hEnd $ hBuild a b c + +>>> let x = hBuild True in hEnd x +H[True] + +>>> let x = hBuild True 'a' in hEnd x +H[True,'a'] + +>>> let x = hBuild True 'a' "ok" in hEnd x +H[True,'a',"ok"] + +hBuild can also produce a Record, such that + +> hBuild x y ^. from unlabeled + +can also be produced using + +@ +'hEndR' $ hBuild x y +@ + +-} + +-- *** historical +{- $hbuild the show instance has since changed, but these uses of +'hBuild'/'hEnd' still work + +> HList> let x = hBuild True in hEnd x +> HCons True HNil + +> HList> let x = hBuild True 'a' in hEnd x +> HCons True (HCons 'a' HNil) + +> HList> let x = hBuild True 'a' "ok" in hEnd x +> HCons True (HCons 'a' (HCons "ok" HNil)) + +> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) +> HCons (Key 42) (HCons (Name "Angus") (HCons Cow (HCons (Price 75.5) HNil))) + +> HList> hEnd (hBuild (Key 42) (Name "Angus") Cow (Price 75.5)) == angus +> True + +-} + +-- -------------------------------------------------------------------------- + +-- * folds +-- ** foldr +-- $foldNote Consume a heterogenous list. + + +class HFoldr f v (l :: [*]) r where + hFoldr :: f -> v -> HList l -> r + +instance (v ~ v') => HFoldr f v '[] v' where + hFoldr _ v _ = v + +-- | uses 'ApplyAB' not 'Apply' +instance (ApplyAB f (e, r) r', HFoldr f v l r) + => HFoldr f v (e ': l) r' where + hFoldr f v (HCons x l) = applyAB f (x, hFoldr f v l :: r) + + +class HScanr f z ls rs where + hScanr :: f -> z -> HList ls -> HList rs + +instance lz ~ '[z] => HScanr f z '[] lz where + hScanr _ z _ = HCons z HNil + +instance (ApplyAB f (x,r) s, HScanr f z xs (r ': rs), + srrs ~ (s ': r ': rs)) => HScanr f z (x ': xs) srrs where + hScanr f z (HCons x xs) = + case hScanr f z xs :: HList (r ': rs) of + HCons r rs -> (applyAB f (x,r) :: s) `HCons` r `HCons` rs + +class HFoldr1 f (l :: [*]) r where + hFoldr1 :: f -> HList l -> r + +instance (v ~ v') => HFoldr1 f '[v] v' where + hFoldr1 _ (HCons v _) = v + +-- | uses 'ApplyAB' not 'Apply' +instance (ApplyAB f (e, r) r', HFoldr1 f (e' ': l) r) + => HFoldr1 f (e ': e' ': l) r' where + hFoldr1 f (HCons x l) = applyAB f (x, hFoldr1 f l :: r) + + +-- ** foldl + +{- | like 'foldl' + + +>>> hFoldl (uncurry $ flip (:)) [] (1 `HCons` 2 `HCons` HNil) +[2,1] + + +-} +class HFoldl f (z :: *) xs (r :: *) where + hFoldl :: f -> z -> HList xs -> r + +instance (zx ~ (z,x), ApplyAB f zx z', HFoldl f z' xs r) + => HFoldl f z (x ': xs) r where + hFoldl f z (x `HCons` xs) = hFoldl f (applyAB f (z,x) :: z') xs + +instance (z ~ z') => HFoldl f z '[] z' where + hFoldl _ z _ = z + + + + + +-- * unfolds + +-- ** unfold +-- $unfoldNote Produce a heterogenous list. Uses the more limited +-- 'Apply' instead of 'App' since that's all that is needed for uses of this +-- function downstream. Those could in principle be re-written. + +-- hUnfold :: (Apply p s, HUnfold' p s) => p -> s -> HList (HUnfold p s) +hUnfold p s = hUnfold' p (apply p s) + +type HUnfold p s = HUnfoldR p (ApplyR p s) + +type family HUnfoldR p res :: [*] +type instance HUnfoldR p HNothing = '[] +type instance HUnfoldR p (HJust (e,s)) = e ': HUnfoldR p (ApplyR p s) + +type HUnfold' p res = HUnfoldFD p (ApplyR p res) (HUnfold p res) + +class HUnfoldFD p res z | p res -> z where + hUnfold' :: p -> res -> HList z + +instance HUnfoldFD p HNothing '[] where + hUnfold' _ _ = HNil + +instance (Apply p s, HUnfoldFD p (ApplyR p s) z) => HUnfoldFD p (HJust (e,s)) (e ': z) where + hUnfold' p (HJust (e,s)) = HCons e (hUnfold p s) + + +-- ** replicate + +{- | + +Sometimes the result type can fix the type of the +first argument: + +>>> hReplicate Proxy () :: HList '[ (), (), () ] +H[(),(),()] + +However, with HReplicate all elements must have the same type, so it may be +easier to use 'HList2List': + +>>> list2HList (repeat 3) :: Maybe (HList [Int, Int, Int]) +Just H[3,3,3] + +-} +class HLengthEq es n => HReplicateFD (n :: HNat) e es + | n e -> es, es -> n where + hReplicate :: Proxy n -> e -> HList es + +instance HReplicateFD HZero e '[] where + hReplicate _ _ = HNil + +instance (HReplicateFD n e es, e ~ e') => HReplicateFD (HSucc n) e (e' ': es) where + hReplicate n e = e `HCons` hReplicate (hPred n) e + +type HReplicate n e = HReplicateFD n e (HReplicateR n e) + +-- | would be associated with 'HReplicate' except we want +-- it to work with `e` of any kind, not just `*` that you can +-- put into a HList. An \"inverse\" of 'HLength' +type family HReplicateR (n :: HNat) (e :: k) :: [k] +type instance HReplicateR HZero e = '[] +type instance HReplicateR (HSucc n) e = e ': HReplicateR n e + +{- | HReplicate produces lists that can be converted to ordinary +lists + +>>> let two = hSucc (hSucc hZero) +>>> let f = Fun' fromInteger :: Fun' Num Integer + +>>> :t applyAB f +applyAB f :: Num b => Integer -> b + +>>> hReplicateF two f 3 +H[3,3] + +>>> hReplicateF Proxy f 3 :: HList [Int, Double, Integer] +H[3,3.0,3] + +-} +class HLengthEq r n => HReplicateF (n :: HNat) f z r | r -> n where + hReplicateF :: HLengthEq r n => Proxy n -> f -> z -> HList r + +instance HReplicateF HZero f z '[] where + hReplicateF _ _ _ = HNil + +instance (ApplyAB f z fz, + HReplicateF n f z r') + => HReplicateF (HSucc n) f z (fz ': r') where + hReplicateF n f z = applyAB f z `HCons` hReplicateF (hPred n) f z + +-- ** iterate +{- | + +This function behaves like 'iterate', with an extra +argument to help figure out the result length + +>>> let three = hSucc (hSucc (hSucc hZero)) +>>> let f = Fun Just :: Fun '() Maybe + +>>> :t applyAB f +applyAB f :: a -> Maybe a + +f is applied to different types: + +>>> hIterate three f () +H[(),Just (),Just (Just ())] + +It is also possible to specify the length later on, +as done with Prelude.'iterate' + +>>> let take3 x | _ <- hLength x `asTypeOf` three = x +>>> take3 $ hIterate Proxy f () +H[(),Just (),Just (Just ())] + +-} +class HLengthEq r n => HIterate n f z r where + hIterate :: HLengthEq r n => Proxy n -> f -> z -> HList r + +instance HIterate HZero f z '[] where + hIterate _ _ _ = HNil + +instance (ApplyAB f z z', + HIterate n f z' r', + z ~ z_) + => HIterate (HSucc n) f z (z_ ': r') where + hIterate n f z = z `HCons` hIterate (hPred n) f (applyAB f z :: z') + +-- * concat + +{- | + +Like 'concat' but for HLists of HLists. + +Works in ghci... puzzling as what is different in doctest (it isn't +@-XExtendedDefaultRules@) + +>>> let a = hEnd $ hBuild 1 2 3 +>>> let b = hEnd $ hBuild 'a' "abc" +>>> hConcat $ hBuild a b +H[1,2,3,'a',"abc"] + +-} +type HConcat xs = HConcatFD xs (HConcatR xs) + +hConcat :: HConcat xs => HList xs -> HList (HConcatR xs) +hConcat x = hConcatFD x + +type family HConcatR (a :: [*]) :: [*] +type instance HConcatR '[] = '[] +type instance HConcatR (x ': xs) = HAppendListR (UnHList x) (HConcatR xs) + +type family UnHList a :: [*] +type instance UnHList (HList a) = a + +-- for the benefit of ghc-7.10.1 +class HConcatFD xxs xs | xxs -> xs + where hConcatFD :: HList xxs -> HList xs + +instance HConcatFD '[] '[] where + hConcatFD _ = HNil + +instance (HConcatFD as bs, HAppendFD a bs cs) => HConcatFD (HList a ': as) cs where + hConcatFD (HCons x xs) = x `hAppendFD` hConcatFD xs + +class HAppendFD a b ab | a b -> ab where + hAppendFD :: HList a -> HList b -> HList ab + +instance HAppendFD '[] b b where + hAppendFD _ b = b + +instance HAppendFD as bs cs => HAppendFD (a ': as) bs (a ': cs) where + hAppendFD (HCons a as) bs = a `HCons` hAppendFD as bs + + +-- -------------------------------------------------------------------------- +-- * traversing HLists + +-- ** producing HList +-- *** map +-- $mapNote It could be implemented with 'hFoldr', as we show further below + +{- | hMap is written such that the length of the result list +can be determined from the length of the argument list (and +the other way around). Similarly, the type of the elements +of the list is propagated in both directions too. + +>>> :set -XNoMonomorphismRestriction +>>> let xs = 1 .*. 'c' .*. HNil +>>> :t hMap (HJust ()) xs +hMap (HJust ()) xs :: Num y => HList '[HJust y, HJust Char] + + +These 4 examples show that the constraint on the length (2 in this case) +can be applied before or after the 'hMap'. That inference is independent of the +direction that type information is propagated for the individual elements. + + +>>> let asLen2 xs = xs `asTypeOf` (undefined :: HList '[a,b]) + +>>> let lr xs = asLen2 (applyAB (HMap HRead) xs) +>>> let ls xs = asLen2 (applyAB (HMap HShow) xs) +>>> let rl xs = applyAB (HMap HRead) (asLen2 xs) +>>> let sl xs = applyAB (HMap HShow) (asLen2 xs) + + +>>> :t lr +lr + :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...] + +>>> :t rl +rl + :: (Read ..., Read ...) => HList '[String, String] -> HList '[..., ...] + + +>>> :t ls +ls + :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String] + +>>> :t sl +sl + :: (Show ..., Show ...) => HList '[..., ...] -> HList '[String, String] + +-} + +newtype HMap f = HMap f + +hMap f xs = applyAB (HMap f) xs + +instance (HMapCxt r f a b, as ~ r a, bs ~ r b) + => ApplyAB (HMap f) as bs where + applyAB (HMap f) = hMapAux f + + +-- | hMap constrained to HList +hMapL f xs = applyAB (HMapL f) xs + +newtype HMapL f = HMapL f + +instance (HMapCxt HList f a b, as ~ HList a, bs ~ HList b) => ApplyAB (HMapL f) as bs where + applyAB (HMapL f) = hMapAux f + + +class (SameLength a b, HMapAux r f a b) => HMapCxt r f a b + +instance (SameLength a b, HMapAux r f a b) => HMapCxt r f a b + + + +class HMapAux (r :: [*] -> *) f (x :: [*]) (y :: [*]) where + hMapAux :: SameLength x y => f -> r x -> r y + +instance HMapAux HList f '[] '[] where + hMapAux _ _ = HNil + +instance (ApplyAB f e e', HMapAux HList f l l', SameLength l l') + => HMapAux HList f (e ': l) (e' ': l') where + hMapAux f (HCons x l) = applyAB f x `HCons` hMapAux f l + + + + +-- -------------------------------------------------------------------------- + +-- **** alternative implementation +-- $note currently broken + +newtype MapCar f = MapCar f + +-- | Same as 'hMap' only a different implementation. +hMapMapCar :: (HFoldr (MapCar f) (HList '[]) l l') => + f -> HList l -> l' +hMapMapCar f = hFoldr (MapCar f) HNil + +instance ApplyAB f e e' => ApplyAB (MapCar f) (e,HList l) (HList (e' ': l)) where + applyAB (MapCar f) (e,l) = HCons (applyAB f e) l + + +-- -------------------------------------------------------------------------- + +-- *** @appEndo . mconcat . map Endo@ +{- | + +>>> let xs = length .*. (+1) .*. (*2) .*. HNil +>>> hComposeList xs "abc" +8 + + +-} +hComposeList + :: (HFoldr Comp (a -> a) l (t -> a)) => HList l -> t -> a +hComposeList fs v0 = let r = hFoldr (Comp :: Comp) (\x -> x `asTypeOf` r) fs v0 in r + + +-- -------------------------------------------------------------------------- + +-- *** sequence +{- | + A heterogeneous version of + + > sequenceA :: (Applicative m) => [m a] -> m [a] + + Only now we operate on heterogeneous lists, where different elements + may have different types 'a'. + In the argument list of monadic values (m a_i), + although a_i may differ, the monad 'm' must be the same for all + elements. That's why we needed "Data.HList.TypeCastGeneric2" (currently (~)). + The typechecker will complain + if we attempt to use hSequence on a HList of monadic values with different + monads. + + The 'hSequence' problem was posed by Matthias Fischmann + in his message on the Haskell-Cafe list on Oct 8, 2006 + + + + + -} + +class (Applicative m, SameLength a b) => HSequence m a b | a -> b, m b -> a where + hSequence :: HList a -> m (HList b) +{- ^ + +[@Maybe@] + +>>> hSequence $ Just (1 :: Integer) `HCons` (Just 'c') `HCons` HNil +Just H[1,'c'] + +>>> hSequence $ return 1 `HCons` Just 'c' `HCons` HNil +Just H[1,'c'] + + +[@List@] + +>>> hSequence $ [1] `HCons` ['c'] `HCons` HNil +[H[1,'c']] + + +-} + +instance Applicative m => HSequence m '[] '[] where + hSequence _ = pure HNil + +instance (m1 ~ m, Applicative m, HSequence m as bs) => + HSequence m (m1 a ': as) (a ': bs) where + hSequence (HCons a b) = liftA2 HCons a (hSequence b) + +-- **** alternative implementation + +-- | 'hSequence2' is not recommended over 'hSequence' since it possibly doesn't +-- allow inferring argument types from the result types. Otherwise this version +-- should do exactly the same thing. +-- +-- The DataKinds version needs a little help to find the type of the +-- return HNil, unlike the original version, which worked just fine as +-- +-- > hSequence l = hFoldr ConsM (return HNil) l + +hSequence2 l = + let rHNil = pure HNil `asTypeOf` (fmap undefined x) + x = hFoldr (LiftA2 FHCons) rHNil l + in x + + + +-- -------------------------------------------------------------------------- + + +-- -------------------------------------------------------------------------- +-- ** producing homogenous lists + +-- *** map (no sequencing) +-- $mapOut This one we implement via hFoldr + +newtype Mapcar f = Mapcar f + +instance (l ~ [e'], ApplyAB f e e', el ~ (e,l)) => ApplyAB (Mapcar f) el l where + applyAB (Mapcar f) (e, l) = applyAB f e : l + +-- A synonym for the complex constraint +type HMapOut f l e = (HFoldr (Mapcar f) [e] l [e]) + +-- | compare @hMapOut f@ with @'hList2List' . 'hMap' f@ +hMapOut :: forall f e l. HMapOut f l e => f -> HList l -> [e] +hMapOut f l = hFoldr (Mapcar f) ([] :: [e]) l + + +-- -------------------------------------------------------------------------- +-- *** mapM + +-- | +-- +-- > mapM :: forall b m a. (Monad m) => (a -> m b) -> [a] -> m [b] +-- +-- Likewise for 'mapM_'. +-- +-- See 'hSequence' if the result list should also be heterogenous. + +hMapM :: (Monad m, HMapOut f l (m e)) => f -> HList l -> [m e] +hMapM f = hMapOut f + +-- | GHC doesn't like its own type. +-- +-- > hMapM_ :: forall m a f e. (Monad m, HMapOut f a (m e)) => f -> a -> m () +-- +-- Without explicit type signature, it's Ok. Sigh. +-- Anyway, Hugs does insist on a better type. So we restrict as follows: +-- +hMapM_ :: (Monad m, HMapOut f l (m ())) => f -> HList l -> m () +hMapM_ f = sequence_ . disambiguate . hMapM f + where + disambiguate :: [q ()] -> [q ()] + disambiguate = id + + + + + +-- -------------------------------------------------------------------------- +-- * Ensure a list to contain HNats only +-- | We do so constructively, converting the HList whose elements +-- are Proxy HNat to [HNat]. The latter kind is unpopulated and +-- is present only at the type level. + +type family HNats (l :: [*]) :: [HNat] +type instance HNats '[] = '[] +type instance HNats (Proxy n ': l) = n ': HNats l + +hNats :: HList l -> Proxy (HNats l) +hNats _ = Proxy + + +-- -------------------------------------------------------------------------- +-- * Membership tests + +-- | Check to see if an HList contains an element with a given type +-- This is a type-level only test + +class HMember (e1 :: k) (l :: [k]) (b :: Bool) | e1 l -> b +instance HMember e1 '[] False +instance (HEq e1 e b, HMember' b e1 l br) => HMember e1 (e ': l) br +class HMember' (b0 :: Bool) (e1 :: k) (l :: [k]) (b :: Bool) | b0 e1 l -> b +instance HMember' True e1 l True +instance (HMember e1 l br) => HMember' False e1 l br + +-- | The following is a similar type-only membership test +-- It uses the user-supplied curried type equality predicate pred +type family HMemberP pred e1 (l :: [*]) :: Bool +type instance HMemberP pred e1 '[] = False +type instance HMemberP pred e1 (e ': l) = HMemberP' pred e1 l (ApplyR pred (e1,e)) + +type family HMemberP' pred e1 (l :: [*]) pb :: Bool +type instance HMemberP' pred e1 l (Proxy True) = True +type instance HMemberP' pred e1 l (Proxy False) = HMemberP pred e1 l + + +hMember :: HMember e l b => Proxy e -> Proxy l -> Proxy b +hMember _ _ = Proxy + +-- ** Another type-level membership test +-- +-- | Check to see if an element e occurs in a list l +-- If not, return 'Nothing +-- If the element does occur, return 'Just l1 +-- where l1 is a type-level list without e +class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r +instance HMemberM e1 '[] 'Nothing +instance (HEq e1 e b, HMemberM1 b e1 (e ': l) res) + => HMemberM e1 (e ': l) res + +class HMemberM1 (b::Bool) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r +instance HMemberM1 True e1 (e ': l) ('Just l) +instance (HMemberM e1 l r, HMemberM2 r e1 (e ': l) res) + => HMemberM1 False e1 (e ': l) res + +class HMemberM2 (b::Maybe [k]) (e1 :: k) (l :: [k]) (r::Maybe [k]) | b e1 l -> r +instance HMemberM2 Nothing e1 l Nothing +instance HMemberM2 (Just l1) e1 (e ': l) (Just (e ': l1)) + +-- -------------------------------------------------------------------------- + +-- * Staged equality for lists +-- $note removed. use Typeable instead + + +{- +-- * Static set property based on HEq +class HSet l +instance HSet HNil +instance (HMember e l HFalse, HSet l) => HSet (HCons e l) +-} + +-- * Find an element in a set based on HEq +-- | It is a pure type-level operation +class HFind1 e l l n => HFind (e :: k) (l :: [k]) (n :: HNat) | e l -> n +instance HFind1 e l l n => HFind e l n + +class HFind1 (e :: k) (l :: [k]) (l0 :: [k]) (n :: HNat) | e l -> n + +instance (HEq e1 e2 b, HFind2 b e1 l l0 n) => HFind1 e1 (e2 ': l) l0 n +instance Fail (FieldNotFound e1 l0) => HFind1 e1 '[] l0 HZero + +class HFind2 (b::Bool) (e :: k) (l::[k]) (l0::[k]) (n:: HNat) | b e l -> n +instance HFind2 True e l l0 HZero +instance HFind1 e l l0 n => HFind2 False e l l0 (HSucc n) + + + +-- ** Membership test based on type equality + +-- | could be an associated type if HEq had one +class HTMember e (l :: [*]) (b :: Bool) | e l -> b +instance HTMember e '[] False +instance (HEq e e' b, HTMember e l b', HOr b b' ~ b'') + => HTMember e (e' ': l) b'' + +hTMember :: HTMember e l b => e -> HList l -> Proxy b +hTMember _ _ = Proxy + + +-- * Intersection based on HTMember + +class HTIntersect l1 l2 l3 | l1 l2 -> l3 + where + -- | Like 'Data.List.intersect' + hTIntersect :: HList l1 -> HList l2 -> HList l3 + +instance HTIntersect '[] l '[] + where + hTIntersect _ _ = HNil + +instance ( HTMember h l1 b + , HTIntersectBool b h t l1 l2 + ) + => HTIntersect (h ': t) l1 l2 + where + hTIntersect (HCons h t) l1 = hTIntersectBool b h t l1 + where + b = hTMember h l1 + +class HTIntersectBool (b :: Bool) h t l1 l2 | b h t l1 -> l2 + where + hTIntersectBool :: Proxy b -> h -> HList t -> HList l1 -> HList l2 + +instance HTIntersect t l1 l2 + => HTIntersectBool True h t l1 (h ': l2) + where + hTIntersectBool _ h t l1 = HCons h (hTIntersect t l1) + +instance HTIntersect t l1 l2 + => HTIntersectBool False h t l1 l2 + where + hTIntersectBool _ _ t l1 = hTIntersect t l1 + + +-- * Convert between heterogeneous lists and homogeneous ones + +-- | @hMapOut id@ is similar, except this function is restricted +-- to HLists that actually contain a value (so the list produced +-- will be nonempty). This restriction allows adding a functional +-- dependency, which means that less type annotations can be necessary. +class HList2List l e | l -> e + where + hList2List :: HList l -> [e] + list2HListSuffix :: [e] -> Maybe (HList l, [e]) + + +list2HList :: HList2List l e => [e] -> Maybe (HList l) +list2HList = fmap fst . list2HListSuffix + + +instance HList2List '[e] e + where + hList2List (HCons e HNil) = [e] + + list2HListSuffix (e : es) = Just (HCons e HNil, es) + list2HListSuffix [] = Nothing + + +instance HList2List (e' ': l) e + => HList2List (e ': e' ': l) e + where + hList2List (HCons e l) = e:hList2List l + + list2HListSuffix (e : es) = (\(hl,rest) -> (HCons e hl, rest)) + <$> list2HListSuffix es + list2HListSuffix [] = Nothing + +-- | @Prism [s] [t] (HList s) (HList t)@ +listAsHList x = prism hList2List (\l -> case list2HListSuffix l of + Just (hl,[]) -> Right hl + _ -> Left []) x + +-- | @Prism' [a] (HList s)@ +-- +-- where @s ~ HReplicateR n a@ +listAsHList' x = isSimple listAsHList x + + +-- -------------------------------------------------------------------------- +-- * With 'HMaybe' + +-- ** Turn list in a list of justs +-- | the same as @map Just@ +-- +-- >>> toHJust (2 .*. 'a' .*. HNil) +-- H[HJust 2,HJust 'a'] +-- +-- >>> toHJust2 (2 .*. 'a' .*. HNil) +-- H[HJust 2,HJust 'a'] + +class FromHJustR (ToHJustR l) ~ l => ToHJust l + where + type ToHJustR l :: [*] + toHJust :: HList l -> HList (ToHJustR l) + +instance ToHJust '[] + where + type ToHJustR '[] = '[] + toHJust HNil = HNil + +instance ToHJust l => ToHJust (e ': l) + where + type ToHJustR (e ': l) = HJust e ': ToHJustR l + toHJust (HCons e l) = HCons (HJust e) (toHJust l) + +-- | alternative implementation. The Apply instance is in "Data.HList.FakePrelude". +-- A longer type could be inferred. +toHJust2 :: (HMapCxt r (HJust ()) a b, + ToHJust a, b ~ ToHJustR a -- added to get equivalent inference + ) => r a -> r b +toHJust2 xs = hMap (HJust ()) xs + +-- -------------------------------------------------------------------------- +-- ** Extract justs from list of maybes +-- +-- >>> let xs = 2 .*. 'a' .*. HNil +-- >>> fromHJust (toHJust xs) == xs +-- True + +class (FromHJustR (ToHJustR l) ~ l) => FromHJust l + where + type FromHJustR l :: [*] + fromHJust :: HList l -> HList (FromHJustR l) + +instance FromHJust '[] + where + type FromHJustR '[] = '[] + fromHJust HNil = HNil + +instance FromHJust l => FromHJust (HNothing ': l) + where + type FromHJustR (HNothing ': l) = FromHJustR l + fromHJust (HCons _ l) = fromHJust l + +instance FromHJust l => FromHJust (HJust e ': l) + where + type FromHJustR (HJust e ': l) = e ': FromHJustR l + fromHJust (HCons (HJust e) l) = HCons e (fromHJust l) + +-- *** alternative implementation + +-- | This implementation is shorter. +fromHJust2 :: (HMapCxt r HFromJust a b) => r a -> r b +fromHJust2 xs = hMap HFromJust xs + +data HFromJust = HFromJust +instance (hJustA ~ HJust a) => ApplyAB HFromJust hJustA a where + applyAB _ (HJust a) = a + + +-- -------------------------------------------------------------------------- +-- * Annotated lists + +data HAddTag t = HAddTag t +data HRmTag = HRmTag + +-- hAddTag :: HMapCxt (HAddTag t) l r => t -> HList l -> HList r +hAddTag t l = hMap (HAddTag t) l + +-- hRmTag :: HMapCxt HRmTag l => HList l -> HList (HMapR HRmTag l) +hRmTag l = hMap HRmTag l + +instance (et ~ (e,t)) => ApplyAB (HAddTag t) e et + where + applyAB (HAddTag t) e = (e,t) + + +instance (e' ~ e) => ApplyAB HRmTag (e,t) e' + where + applyAB _ (e,_) = e + + +-- | Annotate list with a type-level Boolean +-- +-- > hFlag :: HMapCxt (HAddTag (Proxy True)) l r => HList l -> HList r +hFlag l = hAddTag hTrue l + + +-- -------------------------------------------------------------------------- +-- * Splitting by HTrue and HFalse + +-- | Analogus to Data.List.'Data.List.partition' 'snd'. See also 'HPartition' +-- +-- >>> let (.=.) :: p x -> y -> Tagged x y; _ .=. y = Tagged y +-- >>> hSplit $ hTrue .=. 2 .*. hTrue .=. 3 .*. hFalse .=. 1 .*. HNil +-- (H[2,3],H[1]) +-- +-- it might make more sense to instead have @LVPair Bool e@ +-- instead of @(e, Proxy Bool)@ since the former has the same +-- runtime representation as @e@ + +class HSplit l + where + type HSplitT l :: [*] + type HSplitF l :: [*] + hSplit :: HList l -> (HList (HSplitT l), HList (HSplitF l)) + +instance HSplit '[] + where + type HSplitT '[] = '[] + type HSplitF '[] = '[] + hSplit HNil = (HNil,HNil) + +instance HSplit l => HSplit ((e, Proxy True) ': l) + where + + type HSplitT ((e,Proxy True) ': l) = e ': HSplitT l + type HSplitF ((e,Proxy True) ': l) = HSplitF l + + hSplit (HCons (e,_) l) = (HCons e l',l'') + where + (l',l'') = hSplit l + +instance HSplit l => HSplit ((e,Proxy False) ': l) + where + type HSplitT ((e,Proxy False) ': l) = HSplitT l + type HSplitF ((e,Proxy False) ': l) = e ': HSplitF l + + hSplit (HCons (e,_) l) = (l',HCons e l'') + where + (l',l'') = hSplit l + + +instance HSplit l => HSplit (Tagged True e ': l) + where + + type HSplitT (Tagged True e ': l) = e ': HSplitT l + type HSplitF (Tagged True e ': l) = HSplitF l + + hSplit (HCons (Tagged e) l) = (HCons e l',l'') + where + (l',l'') = hSplit l + +instance HSplit l => HSplit (Tagged False e ': l) + where + type HSplitT (Tagged False e ': l) = HSplitT l + type HSplitF (Tagged False e ': l) = e ': HSplitF l + + hSplit (HCons (Tagged e) l) = (l',HCons e l'') + where + (l',l'') = hSplit l +{- + +Let expansion makes a difference to Hugs: + +HListPrelude> let x = (hFlag (HCons "1" HNil)) in hSplit x +(HCons "1" HNil,HNil) +HListPrelude> hSplit (hFlag (HCons "1" HNil)) +ERROR - Unresolved overloading +*** Type : HSplit (HCons ([Char],HTrue) HNil) a b => (a,b) +*** Expression : hSplit (hFlag (HCons "1" HNil)) + + +-} + +-- -------------------------------------------------------------------------- +-- * Splitting by Length + +{- | 'splitAt' + +setup + +>>> let two = hSucc (hSucc hZero) +>>> let xsys = hEnd $ hBuild 1 2 3 4 + +If a length is explicitly provided, the resulting lists are inferred + +>>> hSplitAt two xsys +(H[1,2],H[3,4]) + +>>> let sameLength_ :: SameLength a b => r a -> r b -> r a; sameLength_ = const +>>> let len2 x = x `sameLength_` HCons () (HCons () HNil) + +If the first chunk of the list (a) has to be a certain length, the type of the +Proxy argument can be inferred. + +>>> case hSplitAt Proxy xsys of (a,b) -> (len2 a, b) +(H[1,2],H[3,4]) + +-} +class (HLengthEq xs n, + HAppendList1 xs ys xsys + ) + => HSplitAt (n :: HNat) xsys xs ys + | n xsys -> xs ys + , xs ys -> xsys + , xs -> n + where + hSplitAt :: Proxy n -> HList xsys -> (HList xs, HList ys) + +instance (HSplitAt1 '[] n xsys xs ys, + HAppendList1 xs ys xsys, + HLengthEq xs n) => + HSplitAt n xsys xs ys where + hSplitAt n xsys = hSplitAt1 HNil n xsys + +-- | helper for 'HSplitAt' +class HSplitAt1 accum (n :: HNat) xsys xs ys | accum n xsys -> xs ys where + hSplitAt1 :: HList accum -> Proxy n -> HList xsys -> (HList xs, HList ys) + +instance HRevApp accum '[] xs => HSplitAt1 accum HZero ys xs ys where + hSplitAt1 xs _zero ys = (hReverse_ xs, ys) + +instance HSplitAt1 (b ': accum) n bs xs ys + => HSplitAt1 accum (HSucc n) (b ': bs) xs ys where + hSplitAt1 accum n (HCons b bs) = hSplitAt1 (HCons b accum) (hPred n) bs + +{- | a better way to write @HLength xs ~ n@ because: + +1. it works properly with ghc-7.10 (probably another example of ghc bug #10009) + +2. it works backwards a bit in that if @n@ is known, then @xs@ can be + refined: + +>>> undefined :: HLengthEq xs HZero => HList xs +H[] + +-} +class (SameLength' (HReplicateR n ()) xs, + HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq (xs :: [*]) (n :: HNat) | xs -> n + +instance (SameLength' (HReplicateR n ()) xs, + HLengthEq1 xs n, HLengthEq2 xs n) => HLengthEq xs n + +class HLengthEq1 (xs :: [*]) n -- pick the instance based on n's constructor +instance (HLengthEq xs n, xxs ~ (x ': xs)) => HLengthEq1 xxs (HSucc n) +instance (xxs ~ '[]) => HLengthEq1 xxs HZero + +class HLengthEq2 (xs :: [*]) n | xs -> n -- pick the instance based on xs' constructor +instance (HLengthEq xs n, sn ~ HSucc n) => HLengthEq2 (x ': xs) sn +instance zero ~ HZero => HLengthEq2 '[] zero + +-- | @HLengthGe xs n@ says that @HLength xs >= n@. +-- +-- unlike the expression with a type family HLength, +-- ghc assumes @xs ~ (aFresh ': bFresh)@ when given a +-- constraint @HLengthGe xs (HSucc HZero)@ +class HLengthGe (xs :: [*]) (n :: HNat) +instance (HLengthGe xs n, xxs ~ (x ': xs)) => HLengthGe xxs (HSucc n) +instance HLengthGe xxs HZero + +-- | @HAppendList1 xs ys xsys@ is the type-level way of saying @xs ++ ys == xsys@ +-- +-- used by 'HSplitAt' +class HStripPrefix xs xsys ys + => HAppendList1 (xs :: [k]) (ys :: [k]) (xsys :: [k]) + | xs ys -> xsys, + xs xsys -> ys + -- , ys xsys -> xs + -- hard to prove + +instance HAppendList1 '[] ys ys +instance (HAppendList1 xs ys zs) => HAppendList1 (x ': xs) ys (x ': zs) + + +-- | analog of 'Data.List.stripPrefix' +class HStripPrefix xs xsys ys | xs xsys -> ys +instance (x' ~ x, HStripPrefix xs xsys ys) => HStripPrefix (x' ': xs) (x ': xsys) ys +instance HStripPrefix '[] ys ys + + +-- ** take + +class HTake (n :: HNat) xs ys | n xs -> ys where + hTake :: (HLengthEq ys n, HLengthGe xs n) => Proxy n -> HList xs -> HList ys + +instance HTake HZero xs '[] where + hTake _ _ = HNil + +instance (HLengthEq ys n, HLengthGe xs n, HTake n xs ys) + => HTake (HSucc n) (x ': xs) (x ': ys) where + hTake sn (HCons x xs) = HCons x (hTake (hPred sn) xs) + +-- ** drop + +class HDrop (n :: HNat) xs ys | n xs -> ys where + hDrop :: HLengthGe xs n => Proxy n -> HList xs -> HList ys + +instance HDrop HZero xs xs where + hDrop _ xs = xs + +instance (HLengthGe xs n, HDrop n xs ys) => HDrop (HSucc n) (x ': xs) ys where + hDrop sn (HCons _ xs) = hDrop (hPred sn) xs + + +-- * Conversion to and from tuples + +class HTuple v t | v -> t, t -> v where + -- | alternatively: @hUncurry (,,,)@ + hToTuple :: HList v -> t + hFromTuple :: t -> HList v + +-- | @Iso (HList v) (HList v') a b@ +hTuple x = iso hToTuple hFromTuple x + +-- | @Iso' (HList v) a@ +hTuple' x = isSimple hTuple x + +instance HTuple '[] () where + hToTuple HNil = () + hFromTuple () = HNil + +instance HTuple '[a,b] (a,b) where + hToTuple (a `HCons` b `HCons` HNil) = (a,b) + hFromTuple (a,b) = (a `HCons` b `HCons` HNil) + +instance HTuple '[a,b,c] (a,b,c) where + hToTuple (a `HCons` b `HCons` c `HCons` HNil) = (a,b,c) + hFromTuple (a,b,c) = (a `HCons` b `HCons` c `HCons` HNil) + +instance HTuple '[a,b,c,d] (a,b,c,d) where + hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a,b,c,d) + hFromTuple (a,b,c,d) = (a `HCons` b `HCons` c `HCons` d `HCons` HNil) + +instance HTuple '[a,b,c,d,e] (a,b,c,d,e) where + hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil) = (a,b,c,d,e) + hFromTuple (a,b,c,d,e) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` HNil) + +instance HTuple '[a,b,c,d,e,f] (a,b,c,d,e,f) where + hToTuple (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a,b,c,d,e,f) + hFromTuple (a,b,c,d,e,f) = (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) + + +-- | 'tails' +class HTails a b | a -> b, b -> a where + hTails :: HList a -> HList b + +instance HTails '[] '[HList '[]] where + hTails _ = HCons HNil HNil + +instance (HTails xs ys) => HTails (x ': xs) (HList (x ': xs) ': ys) where + hTails xxs@(HCons _x xs) = xxs `HCons` hTails xs + + +-- | 'inits' +class HInits a b | a -> b, b -> a where + hInits :: HList a -> HList b + +instance HInits1 a b => HInits a (HList '[] ': b) where + hInits xs = HNil `HCons` hInits1 xs + + +-- | behaves like @tail . inits@ +class HInits1 a b | a -> b, b -> a where + hInits1 :: HList a -> HList b + +instance HInits1 '[] '[HList '[]] where + hInits1 _ = HCons HNil HNil + +instance (HInits1 xs ys, + HMapCxt HList (FHCons2 x) ys ys', + HMapCons x ys ~ ys', + HMapTail ys' ~ ys) + => HInits1 (x ': xs) (HList '[x] ': ys') where + hInits1 (HCons x xs) = HCons x HNil `HCons` hMap (FHCons2 x) (hInits1 xs) + + +-- | similar to 'FHCons' +data FHCons2 x = FHCons2 x + +instance (hxs ~ HList xs, + hxxs ~ HList (x ': xs)) + => ApplyAB (FHCons2 x) hxs hxxs where + applyAB (FHCons2 x) xs = HCons x xs + + +-- | evidence to satisfy the fundeps in HInits +type family HMapCons (x :: *) (xxs :: [*]) :: [*] +type instance HMapCons x (HList a ': b) = HList (x ': a) ': HMapCons x b +type instance HMapCons x '[] = '[] + +-- | evidence to satisfy the fundeps in HInits +type family HMapTail (xxs :: [*]) :: [*] +type instance HMapTail ( HList (a ': as) ': bs) = HList as ': HMapTail bs +type instance HMapTail '[] = '[] + + +-- * partition + +{- | @HPartitionEq f x1 xs xi xo@ is analogous to + +> (xi,xo) = partition (f x1) xs + +where @f@ is a \"function\" passed in using it's instance of 'HEqBy' +-} +class HPartitionEq f x1 xs xi xo | f x1 xs -> xi xo where + hPartitionEq :: Proxy f -> Proxy x1 -> HList xs -> (HList xi, HList xo) + +instance HPartitionEq f x1 '[] '[] '[] where + hPartitionEq _ _ _ = (HNil, HNil) + +instance + (HEqBy f x1 x b, + HPartitionEq1 b f x1 x xs xi xo) => HPartitionEq f x1 (x ': xs) xi xo where + hPartitionEq f x1 (HCons x xs) = hPartitionEq1 (Proxy :: Proxy b) f x1 x xs + +class HPartitionEq1 (b :: Bool) f x1 x xs xi xo | b f x1 x xs -> xi xo where + hPartitionEq1 :: Proxy b -> Proxy f -> Proxy x1 -> x -> HList xs -> (HList xi, HList xo) + +instance HPartitionEq f x1 xs xi xo => + HPartitionEq1 True f x1 x xs (x ': xi) xo where + hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of + (xi, xo) -> (x `HCons` xi, xo) + +instance HPartitionEq f x1 xs xi xo => + HPartitionEq1 False f x1 x xs xi (x ': xo) where + hPartitionEq1 _ f x1 x xs = case hPartitionEq f x1 xs of + (xi, xo) -> (xi, x `HCons` xo) + + +-- * groupBy + +{- | @HGroupBy f x y@ is analogous to @y = 'groupBy' f x@ + +given that @f@ is used by 'HEqBy' +-} +class HGroupBy (f :: t) (as :: [*]) (gs :: [*]) | f as -> gs, gs -> as where + hGroupBy :: Proxy f -> HList as -> HList gs + +instance (HSpanEqBy f a as fst snd, + HGroupBy f snd gs) => HGroupBy f (a ': as) (HList (a ': fst) ': gs) where + hGroupBy f (HCons x xs) = case hSpanEqBy f x xs of + (first, second) -> (x `HCons` first) `HCons` hGroupBy f second + +instance HGroupBy f '[] '[] where + hGroupBy _f HNil = HNil + +-- * span + +-- | @HSpanEq x y fst snd@ is analogous to @(fst,snd) = 'span' (== x) y@ +class HSpanEqBy (f :: t) (x :: *) (y :: [*]) (fst :: [*]) (snd :: [*]) + | f x y -> fst snd, fst snd -> y where + hSpanEqBy :: Proxy f -> x -> HList y -> (HList fst, HList snd) + +instance (HSpanEqBy1 f x y fst snd, + HAppendListR fst snd ~ y) + => HSpanEqBy f x y fst snd where + hSpanEqBy f x y = hSpanEqBy1 f x y + +class HSpanEqBy1 (f :: t) (x :: *) (y :: [*]) (i :: [*]) (o :: [*]) + | f x y -> i o where + hSpanEqBy1 :: Proxy f -> x -> HList y -> (HList i, HList o) + +class HSpanEqBy2 (b :: Bool) (f :: t) (x :: *) (y :: *) (ys :: [*]) (i :: [*]) (o :: [*]) + | b f x y ys -> i o where + hSpanEqBy2 :: Proxy b -> Proxy f -> x -> y -> HList ys -> (HList i, HList o) + + +instance (HEqBy f x y b, + HSpanEqBy2 b f x y ys i o) => HSpanEqBy1 f x (y ': ys) i o where + hSpanEqBy1 f x (HCons y ys) = hSpanEqBy2 (Proxy :: Proxy b) f x (y :: y) (ys :: HList ys) + +instance HSpanEqBy1 f x '[] '[] '[] where + hSpanEqBy1 _f _x _xs = (HNil, HNil) + +instance HSpanEqBy1 f x zs i o + => HSpanEqBy2 True f x y zs (y ': i) o where + hSpanEqBy2 _ f x y zs = case hSpanEqBy1 f x zs of + (i, o) -> (HCons y i, o) + +instance HSpanEqBy2 False f x y ys '[] (y ': ys) where + hSpanEqBy2 _b _f _x y ys = (HNil, HCons y ys) + + + +-- * zip + +-- $note see alternative implementations in "Data.HList.HZip" + + + +instance (SameLengths [x,y,xy], HZipList x y xy) => HUnzip HList x y xy where + hUnzip = hUnzipList + +instance (SameLengths [x,y,xy], HZipList x y xy) => HZip HList x y xy where + hZip = hZipList + + +class HZipList x y l | x y -> l, l -> x y where + hZipList :: HList x -> HList y -> HList l + hUnzipList :: HList l -> (HList x, HList y) + +instance HZipList '[] '[] '[] where + hZipList _ _ = HNil + hUnzipList _ = (HNil, HNil) + +instance ((x,y)~z, HZipList xs ys zs) => HZipList (x ': xs) (y ': ys) (z ': zs) where + hZipList (HCons x xs) (HCons y ys) = (x,y) `HCons` hZipList xs ys + hUnzipList (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzipList zs in (x `HCons` xs, y `HCons` ys) + +-- * Monoid instance + +{- | Analogous to the Monoid instance for tuples + +>>> import Data.Monoid +>>> mempty :: HList '[(), All, [Int]] +H[(),All {getAll = True},[]] + +>>> mappend (hBuild "a") (hBuild "b") :: HList '[String] +H["ab"] + +-} +instance + (HProxies a, + HMapCxt HList ConstMempty (AddProxy a) a, + HZip HList a a aa, + HMapCxt HList UncurryMappend aa a) => Monoid (HList a) where + mempty = hMap ConstMempty + $ (hProxies :: HList (AddProxy a)) +#if __GLASGOW_HASKELL__ <= 906 + mappend a b = hMap UncurryMappend $ hZip a b +#endif + +instance + (HZip HList a a aa, + HMapCxt HList UncurryMappend aa a) => Semigroup (HList a) where + a <> b = hMap UncurryMappend $ hZip a b + +-- ** helper functions + +data ConstMempty = ConstMempty +instance (x ~ Proxy y, Monoid y) => ApplyAB ConstMempty x y where + applyAB _ _ = mempty + +data UncurryMappend = UncurryMappend +instance (aa ~ (a,a), Monoid a) => ApplyAB UncurryMappend aa a where + applyAB _ = uncurry mappend + +data UncurrySappend = UncurrySappend +instance (aa ~ (a,a), Semigroup a) => ApplyAB UncurrySappend aa a where + applyAB _ = uncurry (<>) diff --git a/hlist/Data/HList/HListPrelude.hs b/hlist/Data/HList/HListPrelude.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HListPrelude.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE CPP #-} + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Declarations for various classes and functions that + apply for the whole range of heterogeneous collections + (HList, TIP, records, etc). + -} + +module Data.HList.HListPrelude where + +import Data.HList.FakePrelude + + +class HExtend e l where + type HExtendR e l + (.*.) :: e -> l -> HExtendR e l + +infixr 2 .*. + + +-- | to keep types shorter, '.*.' used with Proxy avoids +-- producing a @Proxy :: Proxy '[Label x,Label y,Label z]@ +-- if @Proxy :: Proxy '[x,y,z]@ is not a kind error (as it +-- is when mixing Label6 and Label3 labels). +-- +-- ghc-7.6 does not accept @Proxy ('[] :: [k])@ so for now +-- require @k ~ *@ +instance HExtend (Label x) (Proxy ('[] :: [*])) where + type HExtendR (Label x) (Proxy ('[] :: [*])) = Proxy '[x] + (.*.) _ _ = Proxy + + +-- | similar to 'emptyRecord', 'emptyTIP', emptyHList (actually called 'HNil'), +-- except emptyProxy is the rightmost argument to '.*.' +emptyProxy = Proxy :: Proxy ('[] :: [*]) + +-- Poly-kinded +class SubType l l' + +-- subType :: SubType l l' => l -> l' -> () +-- subType _ _ = () + +class HAppend l1 l2 where + hAppend :: l1 -> l2 -> HAppendR l1 l2 + +-- | poly-kinded, but 'hAppend' only works in cases where the kind variable +-- `k` is `*` +type family HAppendR (l1::k) (l2::k) :: k +-- class HMember e1 l (b :: Bool) | e1 l -> b + +-- One occurrence and nothing is left +class HOccurs e l where + hOccurs :: l -> e + +-- Class to test that a type is "free" in a type sequence +-- polykinded +class HOccursNot (e :: k) (l :: [k]) + +class HProject l l' where + hProject :: l -> l' + +-- | Map a type (key) to a natural (index) within the collection +-- This is a purely type-level computation +class HType2HNat (e :: k) (l :: [k]) (n :: HNat) | e l -> n + +-- | and lift to the list of types +class HTypes2HNats es l (ns :: [HNat]) | es l -> ns + +-- | Delete all elements with the type-level key e from the +-- collection l. Since the key is type-level, it is represented +-- by a Proxy. +-- (polykinded) + +class HDeleteMany e l l' | e l -> l' where + hDeleteMany :: Proxy e -> l -> l' + + +class HDeleteAtLabel (r :: [*] -> *) (l :: k) v v' | l v -> v' where + hDeleteAtLabel :: Label l -> r v -> r v' + + + + +-- | 'unzip' +class SameLengths [x,y,xy] => HUnzip (r :: [*] -> *) x y xy + | x y -> xy, xy -> x y where + hUnzip :: r xy -> (r x, r y) + +-- | 'zip'. Variant supports hUnzip, but not hZip ('hZipVariant' returns a Maybe) +class HUnzip r x y xy => HZip (r :: [*] -> *) x y xy where + hZip :: r x -> r y -> r xy + +#if __GLASGOW_HASKELL__ != 706 +instance (lv ~ Tagged l v, HUnzip Proxy ls vs lvs) + => HUnzip Proxy (Label l ': ls) (v ': vs) (lv ': lvs) where + hUnzip _ = (Proxy, Proxy) + +instance HUnzip Proxy '[] '[] '[] where hUnzip _ = (Proxy, Proxy) + + +{- | Missing from GHC-7.6.3 due to a bug: + +> let r = hEnd $ hBuild 1 2 3 +> *Data.HList> hZipList r r +> H[(1,1),(2,2),(3,3)] +> *Data.HList> hZip r r +> +> :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/hlist/Data/HList/HOccurs.hs b/hlist/Data/HList/HOccurs.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HOccurs.hs @@ -0,0 +1,175 @@ + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Result-type-driven operations on typeful heterogeneous lists. +-} + +module Data.HList.HOccurs ( + module Data.HList.HOccurs, + ) where + +import Data.HList.FakePrelude +import Data.HList.HListPrelude +import Data.HList.HList + +-- -------------------------------------------------------------------------- +-- Given an HList l and an element type e return the suffix of l +-- whose head has the type e. Return HNil if l does not have +-- an element of type e. + +class HOccurrence (e1 :: *) (l :: [*]) (l' :: [*]) | e1 l -> l' where + hOccurrence :: Proxy e1 -> HList l -> HList l' + +instance HOccurrence e1 '[] '[] where + hOccurrence _ = id + +instance (HEq e1 e b, HOccurrence' b e1 (e ': l) l') + => HOccurrence e1 (e ': l) l' where + hOccurrence = hOccurrence' (Proxy::Proxy b) + +class HOccurrence' (b :: Bool) (e1 :: *) (l :: [*]) (l' :: [*]) | b e1 l -> l' where + hOccurrence' :: Proxy b -> Proxy e1 -> HList l -> HList l' + +instance HOccurrence' True e1 (e ': l) (e ': l) where + hOccurrence' _ _ = id + +instance HOccurrence e1 l l' => HOccurrence' False e1 (e ': l) l' where + hOccurrence' _ e (HCons _ l) = hOccurrence e l + + +-- -------------------------------------------------------------------------- +-- Zero or more occurrences + +class HOccursMany e (l :: [*]) where + hOccursMany :: HList l -> [e] + +instance (HOccurrence e l l', HOccursMany' e l') + => HOccursMany e l + where + hOccursMany l = hOccursMany' (hOccurrence (Proxy::Proxy e) l) + +class HOccursMany' e l where + hOccursMany' :: HList l -> [e] + +instance HOccursMany' e '[] where + hOccursMany' _ = [] + +instance (e ~ e1, HOccursMany e l) => HOccursMany' e (e1 ': l) where + hOccursMany' (HCons e l) = e : hOccursMany l + + +-- -------------------------------------------------------------------------- +-- One or more occurrences + +hOccursMany1 :: forall e l l'. + (HOccurrence e l (e ': l'), HOccursMany e l') => + HList l -> (e,[e]) +hOccursMany1 l = case hOccurrence (Proxy :: Proxy e) l of + (HCons e l') -> (e,hOccursMany (l'::HList l')) + +-- -------------------------------------------------------------------------- +-- The first occurrence + +hOccursFst :: forall e l l'. HOccurrence e l (e ': l') => HList l -> e +hOccursFst l = case hOccurrence (Proxy::Proxy e) l of HCons e _ -> e + +-- -------------------------------------------------------------------------- +-- One occurrence and nothing is left +-- This constraint is used in many places + +data TypeNotFound e + +instance (HOccurrence e (x ': y) l', HOccurs' e l' (x ': y)) + => HOccurs e (HList (x ': y)) where + hOccurs = hOccurs' (Proxy :: Proxy (x ': y)) . hOccurrence (Proxy ::Proxy e) + +-- | l0 is the original list so that when we reach the end of l +-- without finding an e, we can report an error that gives an +-- idea about what the original list was. +class HOccurs' e l (l0 :: [*]) where + hOccurs' :: Proxy l0 -> HList l -> e + +instance Fail (FieldNotFound e (HList l0)) => HOccurs' e '[] l0 where + hOccurs' = error "HOccurs'' Fail failed" + +instance HOccursNot e l => HOccurs' e (e ': l) l0 where + hOccurs' _ (HCons e _) = e + +-- | lookup a value in the collection (TIP usually) and return the TIP with that +-- element deleted. Used to implement 'tipyTuple'. +hOccursRest tip = case hOccurs tip of + x -> (x, hDeleteAtLabel (asLabel x) tip) + where asLabel :: x -> Label x + asLabel _ = Label + + +-- -------------------------------------------------------------------------- +-- Zero or at least one occurrence + +hOccursOpt :: forall e l l'. + (HOccurrence e l l', HOccursOpt' e l') => HList l -> Maybe e +hOccursOpt = hOccursOpt' . hOccurrence (Proxy :: Proxy e) + +class HOccursOpt' e l where + hOccursOpt' :: HList l -> Maybe e + +instance HOccursOpt' e '[] where + hOccursOpt' _ = Nothing + +instance e ~ e1 => HOccursOpt' e (e1 ': l) where + hOccursOpt' (HCons e _) = Just e + +-- -------------------------------------------------------------------------- +-- Class to test that a type is "free" in a type sequence + +instance HOccursNot1 e xs xs => HOccursNot e xs + +class HOccursNot1 (e :: k) (xs :: [k]) (xs0 :: [k]) + +instance HOccursNot1 (e :: k) ('[]::[k]) l0 +instance (HEq e e1 b, HOccursNot2 b e l l0) => HOccursNot1 e (e1 ': l) l0 +class HOccursNot2 (b :: Bool) e (l :: [k]) (l0 :: [k]) +instance Fail (ExcessFieldFound e l0) => HOccursNot2 True e l l0 +instance HOccursNot1 e l l0 => HOccursNot2 False e l l0 + + +-- -------------------------------------------------------------------------- + +instance HProject (HList l) (HList '[]) where + hProject _ = HNil + +instance (HOccurs e l, HProject l (HList l')) + => HProject l (HList (e ': l')) + where + hProject l = HCons (hOccurs l) (hProject l) + + +-- -------------------------------------------------------------------------- + +-- * Illustration of typical test scenarios +{- $example + +Retrieve the Breed of an animal. + +> ghci-or-hugs> hOccurs myAnimal :: Breed +> Cow + + +Normal hOccurs requires specification of the result type even if the result +type is determined by the fact that we are faced with a singleton list. + +> ghci-or-hugs> hOccurs (HCons 1 HNil) +> +> :1: +> No instance for (HOccurs e1 (HCons e HNil)) + + +However, hOccurs can be elaborated as improved as follows: + +> ghci-or-hugs> hLookup (HCons 1 HNil) +> 1 + +-} diff --git a/hlist/Data/HList/HSort.hs b/hlist/Data/HList/HSort.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HSort.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE CPP #-} +{- | Description: sorting + +Benchmarks for these functions can be found at +. + +See +for the public interface. + +-} +module Data.HList.HSort where + +import Data.HList.HList +import Data.HList.FakePrelude +import Data.HList.Label3 + +#if __GLASGOW_HASKELL__ > 707 +import GHC.TypeLits (type (<=?), CmpSymbol) +-- | only in ghc >= 7.7 +instance ((x <=? y) ~ b) => HEqBy HLeFn x y b +-- | only in ghc >= 7.7 + +{- | + +>>> let b1 = Proxy :: HEqBy HLeFn "x" "y" b => Proxy b +>>> :t b1 +b1 :: Proxy 'True + +>>> let b2 = Proxy :: HEqBy HLeFn "x" "x" b => Proxy b +>>> :t b2 +b2 :: Proxy 'True + +>>> let b3 = Proxy :: HEqBy HLeFn "y" "x" b => Proxy b +>>> :t b3 +b3 :: Proxy 'False + +-} +instance (HEq (CmpSymbol x y) GT nb, HNot nb ~ b) => HEqBy HLeFn x y b +#endif + +-- | the \"standard\" '<=' for types. Reuses 'HEqBy' +-- +-- Note that ghc-7.6 is missing instances for Symbol and Nat, so that +-- sorting only works 'HNat' (as used by "Data.HList.Label3"). +data HLeFn + +instance HEqByFn HLeFn + +instance (HLe x y ~ b) => HEqBy HLeFn x y b +instance HEqBy HLeFn x y b => HEqBy HLeFn (Tagged x v) (Tagged y w) b +instance HEqBy HLeFn x y b => HEqBy HLeFn (Label x) (Label y) b +instance HEqBy HLeFn x y b => HEqBy HLeFn (Proxy x) (Proxy y) b + +-- | Data.HList.Label3 labels can only be compared if they belong +-- to the same namespace. +instance (HEqBy HLeFn n m b, ns ~ ns') + => HEqBy HLeFn (Lbl n ns desc) (Lbl m ns' desc') b + + +-- | analogous to 'Data.Ord.Down' +data HDown a +instance HEqByFn a => HEqByFn (HDown a) +instance HEqBy f y x b => HEqBy (HDown f) x y b + +-- | The HEqBy instances for @HNeq HLeFn@ gives '<' +data HNeq le +instance HEqByFn a => HEqByFn (HNeq a) +instance (HEqBy le y x b1, HNot b1 ~ b2) => HEqBy (HNeq le) x y b2 + +{- | @HIsAscList le xs b@ is analogous to + +> b = all (\(x,y) -> x `le` y) (xs `zip` tail xs) + +-} +class HEqByFn le => HIsAscList le (xs :: [*]) (b :: Bool) | le xs -> b + +instance HEqByFn le => HIsAscList le '[x] True +instance HEqByFn le => HIsAscList le '[] True +instance (HEqBy le x y b1, +#if __GLASGOW_HASKELL__ > 906 + HEqByFn le, +#endif + HIsAscList le (y ': ys) b2, + HAnd b1 b2 ~ b3) => HIsAscList le (x ': y ': ys) b3 + + +-- | quick sort with a special case for sorted lists +class (SameLength a b, HEqByFn le) => HSortBy le (a :: [*]) (b :: [*]) | le a -> b where + hSortBy :: Proxy le -> HList a -> HList b + +type HSort x y = HSortBy HLeFn x y + +hSort :: HSort x y => HList x -> HList y +hSort xs = hSortBy (Proxy :: Proxy HLeFn) xs + +instance (SameLength a b, + HIsAscList le a ok, + HSortBy1 ok le a b, + HEqByFn le) => HSortBy le a b where + hSortBy = hSortBy1 (Proxy :: Proxy ok) + +instance HSortBy1 True le a a where + hSortBy1 _ _ a = a -- already sorted + +instance HQSortBy le a b => HSortBy1 False le a b where + hSortBy1 _ = hQSortBy + +class HSortBy1 ok le (a :: [*]) (b :: [*]) | ok le a -> b where + hSortBy1 :: Proxy ok -> Proxy le -> HList a -> HList b + +-- * Merge Sort + +{- | HMSortBy is roughly a transcription of this merge sort + +> msort [] = [] +> msort [x] = [x] +> msort [x,y] = hSort2 x y +> msort xs = case splitAt (length xs `div` 2) xs of +> (a,b) -> msort a `merge` msort b + +> hSort2 x y +> | x <= y = [x,y] +> | otherwise = [y,x] + +> merge (x : xs) (y : ys) +> | x > y = y : merge (x : xs) ys +> | otherwise = x : merge xs (y : ys) + +-} +class HEqByFn le => HMSortBy le (a :: [*]) (b :: [*]) | le a -> b where + hMSortBy :: Proxy le -> HList a -> HList b + + +instance HEqByFn le => HMSortBy le '[] '[] where hMSortBy _ x = x +instance HEqByFn le => HMSortBy le '[x] '[x] where hMSortBy _ x = x +instance (HSort2 b x y ab, HEqBy le x y b, HEqByFn le) => + HMSortBy le '[x,y] ab where + hMSortBy _ (a `HCons` b `HCons` HNil) = hSort2 (Proxy :: Proxy b) a b + +class HSort2 b x y ab | b x y -> ab where + hSort2 :: Proxy b -> x -> y -> HList ab + +instance HSort2 True x y '[x,y] where + hSort2 _ x y = x `HCons` y `HCons` HNil + +instance HSort2 False x y '[y,x] where + hSort2 _ x y = y `HCons` x `HCons` HNil + +instance (HMerge le xs' ys' sorted, +#if __GLASGOW_HASKELL__ > 906 + HEqByFn le, +#endif + HMSortBy le ys ys', + HMSortBy le xs xs', + HLengthEq (a ': b ': c ': cs) n2, + HDiv2 n2 ~ n, + HSplitAt n (a ': b ': c ': cs) xs ys) + => HMSortBy le (a ': b ': c ': cs) sorted where + hMSortBy le abbs = case hSplitAt (Proxy :: Proxy n) abbs of + (xs, ys) -> hMerge le (hMSortBy le xs) (hMSortBy le ys) + + +class HMerge le x y xy | le x y -> xy where + hMerge :: Proxy le -> HList x -> HList y -> HList xy + +instance HMerge le '[] '[] '[] where hMerge _ _ _ = HNil +instance HMerge le (x ': xs) '[] (x ': xs) where hMerge _ x _ = x +instance HMerge le '[] (x ': xs) (x ': xs) where hMerge _ _ x = x + +instance (HEqBy le x y b, + HMerge1 b (x ': xs) (y ': ys) (l ': ls) hhs, + HMerge le ls hhs srt) + => HMerge le (x ': xs) (y ': ys) (l ': srt) where + hMerge le xxs yys = case hMerge1 (Proxy :: Proxy b) xxs yys of + (HCons l ls, hhs) -> l `HCons` hMerge le ls hhs + +type HMerge1 b x y min max = (HCond b (HList x) (HList y) (HList min), + HCond b (HList y) (HList x) (HList max)) +hMerge1 b x y = (hCond b x y, hCond b y x) + +-- * Quick sort +{- | HQSortBy is this algorithm + +> qsort (x : xs @ (_ : _)) = case partition (<= x) xs of +> (le, gt) -> qsort le ++ x : qsort gt +> qsort xs = xs + +on random inputs that are not pathological (ie. not already sorted or reverse +sorted) this turns out to be faster than HMSortBy, so it is used by default. + +-} +class HQSortBy le (a :: [*]) (b :: [*]) | le a -> b where + hQSortBy :: Proxy le -> HList a -> HList b + +instance HQSortBy le '[] '[] where hQSortBy _ x = x +instance HQSortBy le '[x] '[x] where hQSortBy _ x = x +instance (HPartitionEq le a (b ': bs) bGeq bLt, + HQSortBy le bLt sortedLt, + HQSortBy le bGeq sortedGeq, + HAppendListR sortedLt (a ': sortedGeq) ~ sorted, + HAppendList sortedLt (a ': sortedGeq)) => + HQSortBy le (a ': b ': bs) sorted where + hQSortBy le (a `HCons` xs) = case hPartitionEq le (Proxy :: Proxy a) xs of + (g,l) -> hQSortBy le l `hAppendList` (a `HCons` hQSortBy le g) + + + + +-- * More efficient HRLabelSet / HLabelSet +{- | Provided the labels involved have an appropriate instance of HEqByFn, +it would be possible to use the following definitions: + +> type HRLabelSet = HSet +> type HLabelSet = HSet + +-} +class HEqByFn lt => HSetBy lt (ps :: [*]) +instance (HEqByFn lt, HSortBy lt ps ps', HAscList lt ps') => HSetBy lt ps + +class HSetBy (HNeq HLeFn) ps => HSet (ps :: [*]) +instance HSetBy (HNeq HLeFn) ps => HSet ps + +{- | + +>>> let xx = Proxy :: HIsSet [Label "x", Label "x"] b => Proxy b +>>> :t xx +xx :: Proxy 'False + +>>> let xy = Proxy :: HIsSet [Label "x", Label "y"] b => Proxy b +>>> :t xy +xy :: Proxy 'True + +-} +class HIsSet (ps :: [*]) (b :: Bool) | ps -> b +instance HIsSetBy (HNeq HLeFn) ps b => HIsSet ps b + +class HEqByFn lt => HIsSetBy lt (ps :: [*]) (b :: Bool) | lt ps -> b +instance (HEqByFn lt, HSortBy lt ps ps', HIsAscList lt ps' b) => HIsSetBy lt ps b + + +-- | @HAscList le xs@ confirms that xs is in ascending order, +-- and reports which element is duplicated otherwise. +class HEqByFn le => HAscList le (ps :: [*]) + +instance (HEqByFn le, HAscList0 le ps ps) => HAscList le ps + +class HEqByFn le => HAscList0 le (ps :: [*]) (ps0 :: [*]) + +class HEqByFn le => HAscList1 le (b :: Bool) (ps :: [*]) (ps0 :: [*]) +instance ( HAscList1 le b (y ': ys) ps0, HEqBy le x y b +#if __GLASGOW_HASKELL__ > 906 + , HEqByFn le +#endif + ) + => HAscList0 le (x ': y ': ys) ps0 +instance HEqByFn le => HAscList0 le '[] ps0 +instance HEqByFn le => HAscList0 le '[x] ps0 + +instance ( Fail '("Duplicated element", y, "using le", le, "in", ys0), HEqByFn le ) + => HAscList1 le False (y ': ys) ys0 +instance HAscList0 le ys ys0 => HAscList1 le True ys ys0 + +{- $setup + +>>> import Data.HList.TypeEqO + +-} diff --git a/hlist/Data/HList/HTypeIndexed.hs b/hlist/Data/HList/HTypeIndexed.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HTypeIndexed.hs @@ -0,0 +1,81 @@ + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Type-indexed operations on typeful heterogeneous lists. +-} + +module Data.HList.HTypeIndexed where + +import Data.HList.FakePrelude +import Data.HList.HListPrelude +import Data.HList.HList +import Data.HList.HArray +import Data.HList.HOccurs () + +-- -------------------------------------------------------------------------- +-- | Map a type to a natural (index within the collection) +-- This is a purely type-level computation + +instance (HEq e1 e b, HType2HNatCase b e1 l n) => HType2HNat e1 (e ': l) n + +-- | Helper class +class HType2HNatCase (b :: Bool) (e :: *) (l :: [*]) (n :: HNat) | b e l -> n +instance HOccursNot e l => HType2HNatCase True e l HZero +instance HType2HNat e l n => HType2HNatCase False e l (HSucc n) + +hType2HNat :: HType2HNat e l n => proxy1 e -> proxy l -> Proxy n +hType2HNat _ _ = Proxy + +-- | And lift to the list of types + +instance HTypes2HNats ('[] :: [*]) (l :: [*]) '[] + +instance (HType2HNat e l n, HTypes2HNats es l ns) + => HTypes2HNats (e ': es) (l :: [*]) (n ': ns) + +hTypes2HNats :: HTypes2HNats es l ns => + Proxy (es :: [*]) -> hlist l -> Proxy (ns :: [HNat]) +hTypes2HNats _ _ = Proxy + +-- -------------------------------------------------------------------------- +-- Implementing the generic interfaces + +instance HDeleteMany e (HList '[]) (HList '[]) where + hDeleteMany _ HNil = HNil + +instance (HEq e1 e b, HDeleteManyCase b e1 e l l1) + => HDeleteMany e1 (HList (e ': l)) (HList l1) where + hDeleteMany p (HCons e l) = + hDeleteManyCase (Proxy :: Proxy b) p e l + +class HDeleteManyCase (b :: Bool) e1 e l l1 | b e1 e l -> l1 where + hDeleteManyCase :: Proxy b -> Proxy e1 -> e -> HList l -> HList l1 + +instance HDeleteMany e (HList l) (HList l1) => HDeleteManyCase True e e l l1 + where + hDeleteManyCase _ p _ l = hDeleteMany p l + + +instance HDeleteMany e1 (HList l) (HList l1) + => HDeleteManyCase False e1 e l (e ': l1) where + hDeleteManyCase _ p e l = HCons e (hDeleteMany p l) + +-- -------------------------------------------------------------------------- +-- Type-indexed operations in terms of the natural-based primitives + +hDeleteAt p l = hDeleteAtHNat (hType2HNat p l) l + +hUpdateAt e l = hUpdateAtHNat (hType2HNat (Just e) l) e l + +hProjectBy ps l = hProjectByHNats (hTypes2HNats ps l) l + +hSplitBy ps l = hSplitByHNats (hTypes2HNats ps l) l + + +-- | should this instead delete the first element of that type? +instance (HDeleteAtHNat n l, HType2HNat e l n, l' ~ HDeleteAtHNatR n l) + => HDeleteAtLabel HList e l l' where + hDeleteAtLabel _ = hDeleteAtHNat (Proxy :: Proxy n) diff --git a/hlist/Data/HList/HZip.hs b/hlist/Data/HList/HZip.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/HZip.hs @@ -0,0 +1,109 @@ + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Zipping and unzipping for (conceptually) lists of pairs. + + Provides two alternative implementations + -} + +module Data.HList.HZip where + +import Data.HList.HList +import Data.HList.FakePrelude + +-- * zip +-- ** functional dependency + +-- $note1 moved to "Data.HList.HList" to avoid an orphan instance + +-- ** type family +-- $note 'hZip2' can be written as a standalone function, with an appropriate +-- type family to calculate the result type. However, that does not seem to +-- be the case for 'hUnzip2', so to re-use some type functions the two are +-- in the same class. + +-- | HZipR in the superclass constraint doesn't hurt, but it doesn't seem to be +-- necessary +class HZipR (MapFst z) (MapSnd z) ~ z => HUnZip z where + type MapFst z :: [*] + type MapSnd z :: [*] + hZip2 :: HList (MapFst z) -> HList (MapSnd z) -> HList z + hUnzip2 :: HList z -> (HList (MapFst z), HList (MapSnd z)) + +instance HUnZip '[] where + type MapFst '[] = '[] + type MapSnd '[] = '[] + hZip2 _ _ = HNil + hUnzip2 _ = (HNil, HNil) + +instance (z ~ (x,y), HUnZip zs) => HUnZip (z ': zs) where + type MapFst (z ': zs) = ( Fst z ': MapFst zs ) + type MapSnd (z ': zs) = ( Snd z ': MapSnd zs ) + hZip2 (HCons x xs) (HCons y ys) = HCons (x,y) (hZip2 xs ys) + hUnzip2 (HCons ~(x,y) zs) = let ~(xs,ys) = hUnzip2 zs in (x `HCons` xs, y `HCons` ys) + + +-- | calculates something like: +-- +-- > [a] -> [b] -> [(a,b)] +-- +-- can be used to give another type for 'hZip2' +-- +-- > hZip2 :: HList a -> HList b -> HList (HZipR a b) +type family HZipR (x::[*]) (y::[*]) :: [*] +type instance HZipR '[] '[] = '[] +type instance HZipR (x ': xs) (y ': ys) = (x,y) ': HZipR xs ys + + +-- ** utility type functions +-- $note do they belong somewhere else? +type family Fst a +type instance Fst (a,b) = a +type family Snd a +type instance Snd (a,b) = b + + +-- * transpose + +{- | this transpose requires equal-length HLists inside a HList: + +>>> import Data.HList.HListPrelude +>>> let ex = (1 .*. 2 .*. HNil) .*. ('a' .*. 'b' .*. HNil) .*. ( 3 .*. 5 .*. HNil) .*. HNil + +The original list: + +>>> ex +H[H[1,2],H['a','b'],H[3,5]] + +And transposed: + +>>> hTranspose ex +H[H[1,'a',3],H[2,'b',5]] + +-} +hTranspose x = hFoldr HZipF (hReplicate (hLength (hHead x)) HNil) x + + +-- ** helpers + +-- | same as 'HZip' but HCons the elements of x onto y. This might be doable as +-- a @hMap f (hZip x y)@, but that one doesn't propagate types as easily it +-- seems. +class HZip3 x y l | x y -> l, l -> x y where + hZip3 :: HList x -> HList y -> HList l + +instance HZip3 '[] '[] '[] where + hZip3 _ _ = HNil + +instance (HList (x ': y) ~ z, HZip3 xs ys zs) => HZip3 (x ': xs) (HList y ': ys) (z ': zs) where + hZip3 (HCons x xs) (HCons y ys) = HCons x y `HCons` hZip3 xs ys + +data HZipF = HZipF +instance ( + HZip3 a b c, + x ~ (HList a, HList b), + y ~ HList c) => ApplyAB HZipF x y + where applyAB _ (x,y) = hZip3 x y diff --git a/hlist/Data/HList/Keyword.hs b/hlist/Data/HList/Keyword.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Keyword.hs @@ -0,0 +1,673 @@ + +{- | Description: keyword arguments + +The public interface is exposed in + +-} +module Data.HList.Keyword ( + + -- * main + Kw(..), + IsKeyFN, + + recToKW, + + -- ** another label type + K(..), + + -- * types for user error + ErrReqdArgNotFound, + ErrUnexpectedKW, + + + -- * demo + -- ** setup data types + -- $setup + -- $ex2 + + -- * Implementation details + -- $imploutline + KWApply(..), + KWApply'(..), + Arg(..), + + + + -- ** producing lists from a function's arguments + reflect_fk, + ReflectFK, + ReflectFK', + + + -- ** collecting arguments + KW(..), + KW'(..), + KWAcc(..), + + -- ** merging default with supplied arguments + KWMerge(..), + KWMerge'(..), + KWMerge''(..), + + HDelete, HDelete', + + + -- * original introduction + -- $originalIntro + + + -- * todo + -- $todo + + -- * internal for type signature prettiness + TaggedToKW, + ) where + +import GHC.TypeLits +import Data.HList.FakePrelude +import Data.HList.TypeEqO +import Data.HList.HListPrelude +import Data.HList.HList +import Data.HList.Record + +{- $setup + + >>> :set -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses + >>> :set -XScopedTypeVariables -XOverlappingInstances -XTypeFamilies + >>> :set -fcontext-stack=100 + +We will be using an example inspired by a graphics toolkit -- the area +which really benefits from keyword arguments. We first define our +labels and useful datatypes + + >>> data Color = Color + >>> data Size = Size + >>> data Origin = Origin + >>> data RaisedBorder = RaisedBorder + + +The number of arguments each keyword must be specified by an 'IsKeyFN' +instance. + + >>> instance IsKeyFN (Color->a->b) True + >>> instance IsKeyFN (Size->a->b) True + >>> instance (a ~ (Int,Int)) => IsKeyFN (Origin->a->b) True + >>> instance IsKeyFN (RaisedBorder->a->b) True + +Note that if a keyword is always followed by a certain type, that +can be specified above using an instance like the one for Origin. + + >>> data CommonColor = Red | Green | Blue deriving Show + >>> data RGBColor = RGBColor Int Int Int deriving Show + +and two functions: + + >>> :{ + let make_square Size n Origin (x0,y0) Color (color::CommonColor) = + unwords ["Square:", show (n :: Int), "at", show (x0,y0), show color] ++ "\n" + :} + + >>> :{ + let make_rect Size (nx,ny) Origin (x0,y0) Color (color::RGBColor) + RaisedBorder border = + unwords ["Rectangle:", show (nx,ny), "at", show (x0,y0), + show color, if border then "raised border" else ""] ++ "\n" + :} + +-} + +{- $ex2 + +We are not interested in really drawing squares and rectangles +here. Therefore, make_square and make_rect return a String, which we +can regard as a ``command'' to be passed to a low-level graphics +library. The functions make_square and make_rect are genuine functions +and can be used as such. They are not keyword argument functions, yet, +but they set the stage. These functions can be considered an +`interface' for the keyword argument functions. We should note that +the functions are polymorphic: for example, `Size' can be any +showable. We must also emphasize the re-use of the labels: The Color +of a square is the value of the enumerated type CommonColor. OTH, the +color of the rectangle is given as an RGB triple. The sizes of the +square and of the rectangle are specified differently too, the same +label notwithstanding. + +Once the user wrote the functions such as make_square and make_rect, +he can _automatically_ convert them to their keyword +alternatives. This transformation is done by a function 'kw'. The user +should pass the positional-argument function (`labeled' as above), +and an HList of default values for some of the labels. The latter may +be HNil if all keyword arguments are required. + +The first example (no defaults) + + >>> kw (make_square .*. HNil) Size (1::Int) Origin (0,10) Color Red :: String + "Square: 1 at (0,10) Red\n" + +we can permute the arguments at wish + + >>> kw (make_square .*. HNil) Color Red Size (1::Int) Origin (0,10) :: String + "Square: 1 at (0,10) Red\n" + +we can also assign a name to a keyword function, or partially apply it: + + >>> :{ + case kw (make_square .*. HNil) Color Red of + f -> "here: " ++ f Origin (0,10) Size (1::Int) +:} +"here: Square: 1 at (0,10) Red\n" + +Note that it is necessary to use a monomorphic pattern binding here (lambda or +case). One way to get around this is to pass @f@ instead of @kw f@ around: + +>>> :{ + let f = hEnd $ hBuild make_square Color Red + in "here: " ++ kw f Origin (0,10) Size (1::Int) +:} +"here: Square: 1 at (0,10) Red\n" + +The following is a more interesting example, with the +defaults: + + >>> :{ +let addDef f = f .*. Origin .*. (0,10) .*. + RaisedBorder .*. True .*. + HNil + in kw (addDef make_square) Size (1::Int) Color Red ++ + kw (addDef make_rect) Color (RGBColor 0 10 255) + Size (1.0::Float, 2.0::Float) +:} +"Square: 1 at (0,10) Red\nRectangle: (1.0,2.0) at (0,10) RGBColor 0 10 255 raised border\n" + +The argument RaisedBorder is not given, and so the default value is +used. Of course, we can override the default: + + >>> :{ +let addDef f = f .*. Origin .*. (0,10) .*. + RaisedBorder .*. True .*. + HNil + in case kw (addDef make_square) Color of + sq -> case kw (addDef make_rect) of + re -> + sq Red Size (1::Int) ++ + re Color (RGBColor 0 10 255) + RaisedBorder False + Size (1.0::Float, 2.0::Float) +:} +"Square: 1 at (0,10) Red\nRectangle: (1.0,2.0) at (0,10) RGBColor 0 10 255 \n" + +We have reshuffled a few arguments, just for fun. As you can see, the +function `kw make_rect defaults' is polyvariadic indeed. We chose to +partially apply 'Color' to the function `kw make_square defaults' -- +so that the function `sq' is positional in its first argument, and +keyword in the rest. + +If we omit a required argument, we get a type error: + +> ] testse1 = let f x = kw make_square HNil Color Red x +> ] in "here: " ++ f Origin (0,10) +> +> Couldn't match `ErrReqdArgNotFound Size' against `[Char]' +> Expected type: ErrReqdArgNotFound Size +> Inferred type: [Char] ... + +The error message seems reasonably clear. Likewise we get an error +message if we pass to a keyword function an argument it does not expect: + +> ] testse2 = let f x = kw make_square HNil Color Red x +> ] in "here: " ++ f Origin (0,10) Size (1::Int) +> ] RaisedBorder False +> +> No instances for (Fail (ErrUnexpectedKW RaisedBorder), +> KWApply [Char] (HCons RaisedBorder (:*: Bool HNil)) [Char]) +> arising from use of `f' at ... +> In the second argument of `(++)', namely +> `f Origin (0,10) Size (1 :: Int) RaisedBorder False' + + +The function 'kw' receives the appropriately labeled function (such +as make_square) and the HList with default values. The function 'kw' +is polymorphic; the overloading is resolved based on the type of the +user function *and* on the type of its continuation. The continuation +indicates if a keyword argument is forthcoming, or not. In the latter +case, 'kw' checks to see if the supplied defaults can provide the +values of the still missing arguments. We see therefore that a +function type is more than it may appear -- the type of a function is +truly a heterogeneous, type level collection! The function 'kw' +traverses that collection, thus performing a limited form of +reflection on Haskell functions. + +-} + + +{- $imploutline + +One of the key tools of the implementation is 'kwapply', which applies +a function to a polymorphic collection of that function's arguments. +The order of the arguments in the collection is irrelevant. The +contraption kwapply can handle polymorphic functions with arbitrary +number of labeled arguments. + +For example, if we define + +> f1 Size n = show n +> f2 Size n Color m = unwords ["size:", show n, "color:", show m] +> f3 Origin x Color m Size n = +> unwords ["origin:", show x, "size:", show n, "color:",show m] + +then we can run + +> katest1 = kwapply f1 (Size .*. () .*. HNil) +> katest11 = kwapply f1 (Size .*. "Large" .*. HNil) +> +> katest2 = kwapply f2 (Size .*. (1::Int) .*. Color .*. Red .*. HNil) +> katest21 = kwapply f2 (Color .*. Red .*. Size .*. (1::Int) .*. HNil) +> +> katest3 = kwapply f3 (Size .*. (1::Int) .*. Origin .*. (2.0::Float) .*. +> Color .*. Red .*. HNil) + +-} + + +-- | Another key contraption is + +reflect_fk:: (ReflectFK fn kws) => fn -> Arg kws '[] +reflect_fk _ = Arg HNil + +{- ^ + +that reflects on a user-supplied function. It converts the *type* of a +user function to a collection of keywords required by that +function. This and the previous contraptions may be used to define an +`extended' version of some user function that takes more arguments -- +without the need to enumerate all arguments of the original +function. We thus infringe on the area of object and module systems. + +The rest of the implementation is just to convert `kw fn defaults' +into the application of kwapply. + +-} + + +-- * The rest of the implementation +{- $impl + +We should note that all implementation is written in the +continuation-passing style (CPS) -- at the term level and especially +at the _typeclass level_. One of the reasons is to avoid relying on +overlapping instances: we compare types with a predicate `TypeEq x y +hbool', obtain the type-level boolean, and dispatch to two +non-overlapping instances of an auxiliary, continuation class. One +instance handles HTrue, and the other the HFalse alternative. Please +see the HList paper for more discussion of this technique. + +The other, equally important reason for the thorough CPS of the +typeclasses is to control the order of evaluation of constraints and +their functional dependencies. The sole reason is to produce +informative error messages. The order of constraints is irrelevant +when all the constraints are satisfied. However, if the user omitted a +required keyword, many of the constraints below will fail. If a +'wrong' constraint fails first, we get a totally off-the-wall error +message that gives us no clue whatsoever about the problem. By tightly +constraining the order via CPS, we are able to force the typechecker +to give informative error messages. + +-} + + + +-- * Errors + +data ErrReqdArgNotFound x +data ErrUnexpectedKW x + + +instance IsKeyFN (Label (s :: Symbol) -> a -> b) True +{- ^ labels that impose no restriction on the type of the (single) argument + which follows + + >>> let testF (_ :: Label "a") (a :: Int) () = a+1 + >>> kw (hBuild testF) (Label :: Label "a") 5 () + 6 + +-} + +{- | The purpose of this instance is to be able to use the same Symbol + (type-level string) at different types. If they are supposed to be the same, + then use 'Label' instead of 'K' + + >>> let kA = K :: forall t. K "a" t + >>> let testF (K :: K "a" Int) a1 (K :: K "a" Integer) a2 () = a1-fromIntegral a2 + + therefore the following options works: + + >>> kw (hBuild testF) kA (5 :: Int) kA (3 :: Integer) () + 2 + + >>> kw (hBuild testF) (K :: K "a" Integer) 3 (K :: K "a" Int) 5 () + 2 + + But you cannot leave off all @Int@ or @Integer@ annotations. + +-} +instance (r ~ (c -> b)) => IsKeyFN ( (K s c) -> r) True + +data K s (c :: *) = K + + +-- * The implementation of KWApply + +class KWApply f arg_values r where + kwapply:: f -> HList arg_values -> r + +instance (r ~ r') => KWApply r '[] r' where + kwapply f _ = f + +instance (HEq kw kw' flag, + KWApply' flag (kw ->a->f') (kw' ': a' ': tail) r) + => KWApply (kw ->a->f') (kw' ': a' ': tail) r where + kwapply = kwapply' (Proxy :: Proxy flag) + +class KWApply' flag f arg_values r where + kwapply':: Proxy flag -> f -> HList arg_values -> r + +instance (v' ~ v, KWApply f' tail r) + => KWApply' True (kw->v->f') (kw ': v' ': tail) r where + kwapply' _ f (HCons kw_ (HCons v' tl)) = + kwapply (f kw_ v') tl + +-- | Rotate the arg list ... +instance (HAppendListR tail '[kw , v] ~ l', + HAppendList tail '[kw, v], + KWApply f l' r) + => KWApply' False f (kw ': v ': tail) r where + kwapply' _ f (HCons kw_ (HCons v tl)) = + kwapply f (hAppend tl (kw_ .*. v .*. HNil)) + +{- | + +The datatype Arg below is to maintain the state of keyword +accumulation: which keywords we need, and which keyword and values we +have already got. +arg_types is the phantom HList of keywords that are yet to be satisfied. +arg_values is the @HList (kw .*. kw_value .*. etc)@ +of already found keywords and their values. +-} + +newtype Arg arg_types arg_values = Arg (HList arg_values) +deriving instance Show (HList vals) => Show (Arg tys vals) + +{- | Reflection on a function: +Given a function, return the type list of its keywords + +>>> :t reflect_fk (undefined::Size->Int->Color->CommonColor->String) +reflect_fk (undefined::Size->Int->Color->CommonColor->String) + :: Arg '[Size, Color] '[] + +>>> :t reflect_fk (undefined::Size->Int->()->Int) +reflect_fk (undefined::Size->Int->()->Int) :: Arg '[Size] '[] + + +-} + +class ReflectFK f (kws :: [*]) +instance (IsKeyFN f flag, ReflectFK' flag f kws) => ReflectFK f kws +class ReflectFK' (flag :: Bool) f kws +instance (kkws ~ (kw ': kws), ReflectFK rest kws) => ReflectFK' True (kw->a->rest) kkws +instance ('[] ~ nil) => ReflectFK' False f nil + + +-- | The main class: collect and apply the keyword arguments + +class KW f arg_desc arg_def r where + kwdo :: f -> arg_desc -> HList arg_def -> r + +instance (IsKeyFN r rflag, + KW' rflag f arg_desc arg_def r) + => KW f arg_desc arg_def r where + kwdo = kw' (Proxy ::Proxy rflag) + +class KW' rflag f arg_desc arg_def r where + kw' :: Proxy rflag -> f -> arg_desc -> HList arg_def -> r + +{- | +If the continuation r does not promise any more keyword +arguments, apply the defaults -} + +instance KWMerge arg_needed arg_values arg_def f r + => KW' False f (Arg arg_needed arg_values) arg_def r where + kw' _ f args_given arg_def = kwmerge args_given arg_def f + +{- | Otherwise, collect the supplied keyword and its value, and recurse for +more: -} + +instance (KWAcc arg_desc kw a f arg_def r, (kw->a->r) ~ kwar) + => KW' True f arg_desc arg_def kwar where + kw' _ f arg_desc arg_def kw_ a = kwaccum arg_desc kw_ a f arg_def + + +{- | Add the needed arguments from arg_def to arg_values and continue +with kwapply. + +That is, we try to satisfy the missing arguments from the defaults. +It will be a type error if some required arguments are missing -} + +class KWMerge arg_needed arg_values arg_def f r where + kwmerge:: Arg arg_needed arg_values -> HList arg_def -> f -> r + +instance KWApply f arg_values r + => KWMerge '[] arg_values arg_def f r where + kwmerge (Arg arg_values) _ f = kwapply f arg_values + +instance KWMerge' kw arg_def atail arg_values arg_def f r + => KWMerge (kw ': atail) arg_values arg_def f r where + kwmerge (Arg arg_values) arg_def = + kwmerge' (undefined :: kw) arg_def + ((Arg arg_values)::Arg atail arg_values) arg_def + +class KWMerge' kw list atail arg_values arg_def f r where + kwmerge':: kw -> HList list -> (Arg atail arg_values) -> HList arg_def -> f -> r + +instance (Fail (ErrReqdArgNotFound kw), nff ~ (ErrReqdArgNotFound kw)) + => KWMerge' kw '[] atail arg_values arg_def f + nff where + kwmerge' = undefined +instance (HEq kw kw' flag, + KWMerge'' flag kw (kw' ': etc) atail arg_values arg_def f r) + => KWMerge' kw (kw' ': etc) atail arg_values arg_def f r where + kwmerge' = kwmerge'' (Proxy :: Proxy flag) + +class KWMerge'' (flag :: Bool) kw (list :: [*]) atail arg_values arg_def f r + where + kwmerge'':: Proxy flag -> kw -> HList list + -> Arg atail arg_values -> HList arg_def + -> f -> r +instance KWMerge atail (kw ': v ': arg_values) arg_def f r + => KWMerge'' True kw (kw ': v ': tail) + atail arg_values arg_def f r where + kwmerge'' _ _ (HCons kw_ (HCons v _)) (Arg arg_values) = + kwmerge ((Arg (kw_ .*. v .*. arg_values)):: + (Arg atail (kw ': v ': arg_values))) +instance KWMerge' kw tail atail arg_values arg_def f r + => KWMerge'' False kw (kw' ': v' ': tail) + atail arg_values arg_def f r where + kwmerge'' _ kw_ (HCons _ (HCons _ tl)) = kwmerge' kw_ tl + +-- | Add the real argument to the Arg structure, and continue + +class KWAcc arg_desc kw a f arg_def r where + kwaccum:: arg_desc -> kw -> a -> f -> HList arg_def -> r + + +instance (HDelete kw arg_types arg_types', + KW f (Arg arg_types' (kw ': a ': arg_values)) arg_def r) + => KWAcc (Arg arg_types arg_values) kw a f arg_def r where + kwaccum (Arg arg_values) kw_ a f = + kwdo f (Arg (kw_ .*. a .*. arg_values):: + Arg arg_types' (kw ': a ': arg_values)) + + +-- | Delete e from l to yield l' The element e must occur in l + +class HDelete e (l :: [k]) (l' :: [k]) +instance (Fail (ErrUnexpectedKW e), r ~ '[]) => HDelete e '[] r +instance (HEq e e' flag, HDelete' flag e (e' ': tail) l') + => HDelete e (e' ': tail) l' +class HDelete' (flag :: Bool) e l l' +instance (tail' ~ tail) => HDelete' True e (e ': tail) tail' +instance (HDelete e tail tail', e'tail ~ (e' ': tail')) + => HDelete' False e (e' ': tail) e'tail + + +{- | + +@kw@ takes a 'HList' whose first element is a function, and the rest +of the elements are default values. +A useful trick is to have a final argument @()@ which is not +eaten up by a label (A only takes 1 argument). That way when you supply +the () it knows there are no more arguments (?). + +>>> data A = A +>>> instance IsKeyFN (A -> a -> b) True +>>> let f A a () = a + 1 +>>> let f' = f .*. A .*. 1 .*. HNil + +>>> kw f' A 0 () +1 + +>>> kw f' () +2 + +-} +class Kw (fn :: *) (arg_def :: [*]) r where + kw :: HList (fn ': arg_def) -> r + +instance + (KW' rflag fn akws arg_def r, + akws ~ (Arg (kws :: [*]) '[]), + ReflectFK' flag fn kws, IsKeyFN r rflag, + IsKeyFN fn (flag::Bool)) => Kw fn arg_def r + where + kw (HCons f arg_def) = kwdo f rfk arg_def :: r + where rfk = reflect_fk f :: akws + +data TaggedToKW = TaggedToKW +instance (x ~ Tagged l v, y ~ HList '[Label l, v]) => + ApplyAB TaggedToKW x y where + applyAB _ (Tagged v) = hBuild Label v + + +{- | convert a 'Record' into a list that can supply +default arguments for 'kw' + +A bit of setup: + +>>> :set -XQuasiQuotes +>>> import Data.HList.RecordPuns +>>> let f (_ :: Label "a") a (_ :: Label "b") b () = a `div` b + + +>>> let a = 2; b = 1; f' = f .*. recToKW [pun| a b |] +>>> kw f' () +2 + +>>> kw f' (Label :: Label "a") 10 () +10 + + +-} +recToKW :: forall a b. (HMapCxt HList TaggedToKW a b, HConcat b) => + Record a -> HList (HConcatR b) +recToKW (Record r) = hConcat (hMap TaggedToKW r :: HList b) + +{- $originalIntro + +> From oleg-at-okmij.org Fri Aug 13 14:58:35 2004 +> To: haskell@haskell.org +> Subject: Keyword arguments +> From: oleg-at-pobox.com +> Message-ID: <20040813215834.F1FF3AB7E@Adric.metnet.navy.mil> +> Date: Fri, 13 Aug 2004 14:58:34 -0700 (PDT) +> Status: OR + + +We show the Haskell implementation of keyword arguments, which goes +well beyond records (e.g., in permitting the re-use of +labels). Keyword arguments indeed look just like regular, positional +arguments. However, keyword arguments may appear in any +order. Furthermore, one may associate defaults with some keywords; the +corresponding arguments may then be omitted. It is a type error to +omit a required keyword argument. The latter property is in stark +contrast with the conventional way of emulating keyword arguments via +records. Also in marked contrast with records, keyword labels may be +reused throughout the code with no restriction; the same label may be +associated with arguments of different types in different +functions. Labels of Haskell records may not be re-used. Our solution +is essentially equivalent to keyword arguments of DSSSL Scheme or +labels of OCaml. + +Keyword argument functions are naturally polyvariadic: Haskell does +support varargs! Keyword argument functions may be polymorphic. As +usual, functions with keyword arguments may be partially applied. On +the downside, sometimes one has to specify the type of the return +value of the function (if the keyword argument function has no +signature -- the latter is the norm, see below) -- provided that the +compiler cannot figure the return type out on its own. This is usually +only the case when we use keyword functions at the top level (GHCi +prompt). + +Our solution requires no special extensions to Haskell and works with +the existing Haskell compilers; it is tested on GHC 6.0.1. The +overlapping instances extension is not necessary (albeit it is +convenient). + +The gist of our implementation is the realization that the type of a +function is a polymorphic collection of its argument types -- a +collection that we can traverse. This message thus illustrates a +limited form of the reflection on a function. + + +Our implementation is a trivial extension of the strongly-typed +polymorphic open records described in + + +In fact, the implementation relies on the HList library. To run the +code (which this message is), one needs to download the HList library +from the above site. + +The HList paper discusses the issue of labels in some detail. The +paper gives three different representations. One of them needs no +overlapping instances and is very portable. In this message, we chose +a representation that relies on generic type equality and therefore +needs overlapping instances as implemented in GHC. Again, this is +merely an outcome of our non-deterministic choice. It should be +emphasized that other choices are possible, which do not depend on +overlapping instances at all. Please see the HList paper for details. + +-} + + +{- $todo + +[@better instances for Symbol@] + +There isn't a pair @(K2 \"Origin\" (Int, Int))@ @(K \"hi\")@ that behaves just like Origin below. +something is possible between constraintkinds. See 'Data.HList.FakePrelude.Fun' + +> instance (a ~ (Int,Int)) => IsKeyFN (Origin->a->b) True + +[@wildcard/catchall@] + +like in R. This would be a special keyword for keyword args that didn't match. +They would be put in a HList/Record argument like @...@ + +[@investigate first-classness of varargs@] +for whatever reason you can't have @f = kw fn blah@ and then pass more arguments +on to fn. This is bad. It used to work (in the ghc6.0 days and probably up to +6.12). Some convenience functions/operators should be added which do the same +thing as: + +> fn `hAppendList` hBuild a b c d e + + +-} diff --git a/hlist/Data/HList/Label3.hs b/hlist/Data/HList/Label3.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Label3.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE CPP #-} + +{- | + + Description : namespaced labels + + The HList library + + (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + A model of labels as needed for extensible records. As before, + all the information about labels is recorded in their type, so + the labels of records may be purely phantom. In general, + Labels are exclusively type-level entities and have no run-time + representation. + + Record labels are triplets of type-level naturals, namespace, + and description. The namespace part helps avoid confusions between + labels from different Haskell modules. The description is + an arbitrary nullary type constructor. + + For the sake of printing, the description is required to be the + instance of Show. One must make sure that the show functions does + not examine the value, as descr is purely phantom. Here's an + example of the good Label description: + + > data MyLabelDescr; instance Show MyLabelDescr where show _ = "descr" + + which are automated by makeLabels3 from "Data.HList.MakeLabel". + + This model even allows the labels in a record to belong to different + namespaces. To this end, the model employs the predicate for type + equality. +-} + +module Data.HList.Label3 where + +import Data.HList.FakePrelude +import Data.HList.HListPrelude +import GHC.TypeLits + +{- $setup + +>>> let label3 = Label :: Label (Lbl HZero () ()) +>>> let label6 = Label :: Label "6" + +-} + +data Lbl (x :: HNat) (ns :: *) (desc :: *) -- labels are exclusively type-level entities +#if OLD_TYPEABLE +instance (ShowLabel x) => Typeable2 (Lbl x) where + typeOf2 _ = mkTyConApp (mkTyCon3 "HList" "Data.HList.Label3" "Lbl") + [mkTyConApp (mkTyCon3 "GHC" "GHC.TypeLits" (showLabel (Label :: Label x))) + []] +#endif + +type instance ZipTagged (Lbl ix ns n ': ts) (v ': vs) = Tagged (Lbl ix ns n) v ': ZipTagged ts vs + +instance (Label t ~ Label (Lbl ix ns n)) => SameLabels (Label t) (Lbl ix ns n) + +-- * Public constructors for labels + +-- | Construct the first label +firstLabel :: ns -> desc -> Label (Lbl HZero ns desc) +firstLabel _ _ = Label + + +-- | Construct the next label +nextLabel :: Label (Lbl x ns desc) -> desc' -> Label (Lbl (HSucc x) ns desc') +nextLabel _ _ = Label + + +-- | Equality on labels (descriptions are ignored) +-- Use generic instance +{- +instance ( HEq x x' b + , HEq ns ns' b' + , bres ~ HAnd b b' + ) + => HEq (Lbl x ns desc) (Lbl x' ns' desc') bres +-} + +-- | Show label + +instance Show desc => ShowLabel (Lbl x ns desc) where + showLabel = show . getd + where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs + getd = error "Data.HList.Label3 desc" + +instance Show desc => Show (Label (Lbl x ns desc)) + where + show = show . getd + where getd :: Label (Lbl x ns desc) -> desc -- for the sake of Hugs + getd = error "Data.HList.Label3 desc" + + + +{- | + +If possible, Label is left off: + +>>> let q = label3 .*. label3 .*. emptyProxy +>>> :t q +q :: Proxy '[Lbl 'HZero () (), Lbl 'HZero () ()] + +-} +instance HExtend (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs)) where + type HExtendR (Label (Lbl n ns desc)) (Proxy (Lbl n' ns' desc' ': xs)) + = Proxy (Lbl n ns desc ': Lbl n' ns' desc' ': xs) + (.*.) _ _ = Proxy + +{- | Mixing two label kinds means we have to include 'Label': + +>>> let r = label3 .*. label6 .*. emptyProxy +>>> :t r +r :: Proxy '[Label (Lbl 'HZero () ()), Label "6"] + +-} +instance HExtend (Label (Lbl n ns desc)) (Proxy (x ': xs :: [Symbol])) where + type HExtendR (Label (Lbl n ns desc)) (Proxy (x ': xs)) + = Proxy (Label (Lbl n ns desc) ': MapLabel (x ': xs)) + (.*.) _ _ = Proxy + +{- | Mixing two label kinds means we have to include 'Label': + +>>> let s = label6 .*. label3 .*. emptyProxy +>>> :t s +s :: Proxy '[Label "6", Label (Lbl 'HZero () ())] + +-} +instance HExtend (Label (y :: Symbol)) (Proxy ((x :: *) ': xs)) where + type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Symbol)) (Proxy ((x :: Nat) ': xs)) where + type HExtendR (Label (y :: Symbol)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Nat)) (Proxy ((x :: *) ': xs)) where + type HExtendR (Label (y :: Nat)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Nat)) (Proxy ((x :: Symbol) ': xs)) where + type HExtendR (Label (y :: Nat)) (Proxy (x ': xs)) + = Proxy (Label y ': (MapLabel (x ': xs))) + (.*.) _ _ = Proxy + +-- | similar to Data.HList.Record.Labels1, but avoids producing Label (Label x) +type family MapLabel (xs :: [k]) :: [*] +type instance MapLabel '[] = '[] +#if NO_CLOSED_TF +-- if we can't have any overlap in the TF (ghc-7.6), cover the Label3/Label6 case +type instance MapLabel ((x :: Symbol) ': xs) = Label x ': MapLabel xs +type instance MapLabel (Lbl n ns desc ': xs) = Label (Lbl n ns desc) ': MapLabel xs +type instance MapLabel (Label x ': xs) = Label x ': MapLabel xs +#else +type instance MapLabel (x ': xs) = AddLabel x ': MapLabel xs +type family AddLabel (x :: k) :: * where + AddLabel (Label x) = Label x + AddLabel x = Label x +#endif diff --git a/hlist/Data/HList/Label5.hs b/hlist/Data/HList/Label5.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Label5.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} +#if (__GLASGOW_HASKELL__ < 709) +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif +#if __GLASGOW_HASKELL__ > 906 +{-# LANGUAGE LambdaCase #-} +#endif +{- | + Description: labels are any instance of Typeable + + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Yet another model of labels. + + This model allow us to use any type as label type. + As a result, we need some generic instances. + + Also, type errors may be more confusing now. +-} + +module Data.HList.Label5 where + +import Data.Typeable +import Data.Char +import Data.HList.FakePrelude + + +-- | Equality on labels + +-- instance TypeEq x y b => HEq x y b + + +-- | Show label +instance {-# OVERLAPPABLE #-} Typeable (x :: *) => ShowLabel x + where + showLabel _ = (\l -> case l of [] -> [] ; (x:xs) -> toLower x:xs) + . reverse + . takeWhile (not . (==) '.') + . reverse + . show +{- + . tyConString + . typeRepTyCon +-} + . typeOf $ (error "Data.HList.Label5 has a strict typeOf" :: x) diff --git a/hlist/Data/HList/Label6.hs b/hlist/Data/HList/Label6.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Label6.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{- | + Description : labels using promoted strings (Symbol) + + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + + Yet another model of labels. + + Labels are promoted Strings or Integers "GHC.TypeLits" inside the + 'Label'. Needs ghc7.6 or higher. + + See for an example. + +-} + +module Data.HList.Label6 () where + +import Data.HList.FakePrelude +import GHC.TypeLits +import Data.HList.HListPrelude + +#if MIN_VERSION_base(4,7,0) +instance KnownSymbol x => ShowLabel (x :: Symbol) where + showLabel _ = symbolVal (Proxy :: Proxy x) +instance KnownNat x => ShowLabel (x :: Nat) where + showLabel _ = show $ natVal (Proxy :: Proxy x) +#else +instance SingI x => ShowLabel (x :: Symbol) where + showLabel _ = fromSing (sing :: Sing x) + +instance SingI x => ShowLabel (x :: Nat) where + showLabel _ = show (fromSing (sing :: Sing x)) +#endif + + + +{- | + +>>> let labelX = Label :: Label "x" +>>> let labelY = Label :: Label "y" +>>> let p = labelX .*. labelY .*. emptyProxy +>>> :t p +p :: Proxy '["x", "y"] + +-} +instance HExtend (Label (y :: Symbol)) (Proxy (x ': xs :: [Symbol])) where + type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs) + (.*.) _ _ = Proxy + +instance HExtend (Label (y :: Nat)) (Proxy (x ': xs :: [Nat])) where + type HExtendR (Label y) (Proxy (x ': xs)) = Proxy (y ': x ': xs) + (.*.) _ _ = Proxy diff --git a/hlist/Data/HList/Labelable.hs b/hlist/Data/HList/Labelable.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Labelable.hs @@ -0,0 +1,355 @@ +{- | + +Description : labels which are also lenses (or prisms) + +A simple problem is being solved here, but unfortunately it +is a bit involved. The idea is to use the same haskell identifier +for a lens and for other purposes. In other words, get the same +behavior as: + + > x = hLens (Label :: Label "x") + > r ^. x + +While still being able to extract the symbol \"x\" from x, so that things +like @x .=. 123@ could be acceptable. In this case we don't overload '.=.', +so instead you have to write @x .==. 123@. + + +Elaboration of some ideas from edwardk. +-} +module Data.HList.Labelable + (Labelable(..), + LabeledOptic, + (.==.), + + + -- * multiple lookups + Projected(..), projected', + + -- * comparison with 'hLens' + -- $comparisonWithhLensFunction + + -- * likely unneeded (re)exports + LabeledCxt1, + LabeledTo(LabeledTo), + LabeledR(LabeledR), + ToSym, EnsureLabel(toLabel), toLabelSym, + Identity, + LabelableTIPCxt, + LabeledOpticType(..), + + LabeledOpticF, + LabeledOpticP, + LabeledOpticTo, + ) where + + + +import Data.HList.HListPrelude +import Data.HList.FakePrelude +import Data.HList.Record +import Data.HList.Variant +import Data.HList.TIP +import Data.HList.TIC +import Data.HList.Label3 + +import Control.Monad.Identity +import GHC.TypeLits +import LensDefs +import GHC.Exts (Constraint) + +{- | This alias is the same as Control.Lens.Optic, except the (->) in Optic +is a type parameter 'to' in LabeledOptic. + +Depending on the collection type (see instances of 'LabelableTy'), +the type variables @to, p, f@ are constrained such that the resulting +type is a @Lens (r s) (r t) a b@, @Prism (r s) (r t) a b@ or a +@LabeledTo x _ _@. The latter can be used to recover the label (@x@) when +used as an argument to '.==.' or equivalently 'toLabel'. +-} +type LabeledOptic (x :: k) (r :: [*] -> *) (s :: [*]) (t :: [*]) (a :: *) (b :: *) + = forall ty to p f. + (ty ~ LabelableTy r, + LabeledOpticF ty f, + LabeledOpticP ty p, + LabeledOpticTo ty x to) => (a `p` f b) `to` (r s `p` f (r t)) + +data LabeledOpticType = LabelableLens | LabelablePrism | LabelableLabel + +type family LabeledOpticF (ty :: LabeledOpticType) :: (* -> *) -> Constraint +type instance LabeledOpticF LabelableLens = Functor +type instance LabeledOpticF LabelablePrism = Applicative +type instance LabeledOpticF LabelableLabel = (~) Identity + +type family LabeledOpticP (ty :: LabeledOpticType) :: (* -> * -> *) -> Constraint +type instance LabeledOpticP LabelableLens = (~) (->) +type instance LabeledOpticP LabelablePrism = Choice +type instance LabeledOpticP LabelableLabel = (~) (->) + +type family LabeledOpticTo (ty :: LabeledOpticType) (x :: k) :: (* -> * -> *) -> Constraint +type instance LabeledOpticTo LabelableLens x = (~) (->) +type instance LabeledOpticTo LabelablePrism x = (~) (->) +type instance LabeledOpticTo LabelableLabel x = (~) (LabeledTo x) + + +{- | + +[@r@] is 'Record', 'Variant'. 'TIP' and 'TIC' also have instances, but generally +'tipyLens'' and 'ticPrism'' are more appropriate. + +[@x@] is the label for the field. It tends to have kind 'GHC.TypeLits.Symbol', +but others are supported in principle. + +-} +class SameLength s t => Labelable (x :: k) (r :: [*] -> *) s t a b + | x s -> a, x t -> b, -- lookup + x s b -> t, x t a -> s -- update + where + type LabelableTy r :: LabeledOpticType + hLens' :: Label x -> LabeledOptic x r s t a b + +data LabeledTo (x :: k) (a :: *) (b :: *) = LabeledTo deriving (Show) + +data LabeledR (x :: [*]) = LabeledR + +{- if __GLASGOW_HASKELL__ > 800 +-- should this orphan instance really be supplied? ghc 8's +-- -XOverloadedLabels is uglier syntax than HListPP, and it +-- seems likely that other users of IsLabel probably define +-- an instance for (->) which will be chosen over this one +-- when labels are composed with (.), +-- (or alternatively there will be complaints about overlap) +instance (x ~ x', Labelable x r s t a b) => IsLabel x (LabeledOptic x' r s t a b) where + fromLabel _ = hLens' (Label :: Label x) +-- endif +-} + + +-- | make a @Lens (Record s) (Record t) a b@ +instance HLens x Record s t a b + => Labelable x Record s t a b where + type LabelableTy Record = LabelableLens + hLens' x = hLens x + +-- | used with 'toLabel' and/or '.==.' +instance LabeledCxt1 s t a b => Labelable x LabeledR s t a b where + type LabelableTy LabeledR = LabelableLabel + hLens' _ = LabeledTo + +-- | sets all type variables to dummy values: only the @Labeled x@ +-- part is actually needed +type LabeledCxt1 s t a b = (s ~ '[], t ~ '[], a ~ (), b ~ ()) + +-- | make a @Prism (Variant s) (Variant t) a b@ +instance (HPrism x s t a b, + to ~ (->)) => Labelable x Variant s t a b where + type LabelableTy Variant = LabelablePrism + hLens' x s = hPrism x s + +-- | @hLens' :: Label a -> Prism' (TIC s) a@ +-- +-- note that a more general function @'ticPrism' :: Prism (TIC s) (TIC t) a b@, +-- cannot have an instance of Labelable +-- +-- Note: `x :: k` according to the instance head, but the instance body +-- forces the kind variable to be * later on. IE. (k ~ *) +instance (TICPrism s t a b, Label x ~ Label a,a ~ b, s ~ t, + SameLength s t) => + Labelable (x :: k) TIC s t a b where + type LabelableTy TIC = LabelablePrism + hLens' _ = ticPrism + + +-- | make a @Lens' (TIP s) a@. +-- +-- 'tipyLens' provides a @Lens (TIP s) (TIP t) a b@, which tends to need +-- too many type annotations to be practical +instance LabelableTIPCxt x s t a b => + Labelable (x :: k) TIP s t a b where + type LabelableTy TIP = LabelableLens + hLens' x = hLens x + +type LabelableTIPCxt x s t a b = + (s ~ t, a ~ b, Label x ~ Label a, + HLens x TIP s t a b) + + +-- | modification of '.=.' which works with the labels from this module, +-- and those from "Data.HList.Label6". Note that this is not strictly a +-- generalization of '.=.', since it does not work with labels like +-- "Data.HList.Label3" which have the wrong kind. +l .==. v = toLabel l .=. v + +infixr 4 .==. + +-- | Get the Symbol out of a 'Label' or 'LabeledTo' +class ToSym label (s :: Symbol) | label -> s + +instance LabeledTo x (a `p` f b) (LabeledR s `p` f (LabeledR t)) ~ v1 v2 v3 + => ToSym (v1 v2 v3) x + +instance ToSym (label x) x + +{- | Convert a type to @Label :: Label blah@ + +> toLabel :: LabeledTo x _ _ -> Label (x :: Symbol) +> toLabel (hLens' lx) = (lx :: Label x) +> toLabel :: Label x -> Label x +> toLabel :: Proxy x -> Label x + +-} +class EnsureLabel x y | x -> y where + toLabel :: x -> y + +instance EnsureLabel (Label x) (Label (x :: k)) where + toLabel _ = Label + +instance EnsureLabel (Proxy x) (Label (x :: k)) where + toLabel _ = Label + +-- | get the Label out of a 'LabeledTo' (ie. `foobar when using HListPP). +instance ToSym (a b c) (x :: Symbol) => EnsureLabel (a b c) (Label x) where + toLabel _ = Label + + +-- | fix the `k` kind variable to 'Symbol' +toLabelSym label = toLabel label `asTypeOf` (Label :: Label (x :: Symbol)) + + +{- $comparisonWithhLensFunction + +Note that passing around variables defined with 'hLens'' doesn't get +you exactly the same thing as calling 'hLens' at the call-site: + +The following code needs to apply the @x@ for different @Functor +f =>@, so you would have to write a type signature (rank-2) to allow this +definition: + + > -- with the x defined using hLens' + > let f x r = let + > a = r ^. x + > b = r & x .~ "6" + > in (a,b) + +This alternative won't need a type signature + + > -- with the x defined as x = Label :: Label "x" + > let f x r = let + > a = r ^. hLens x + > b = r & hLens x .~ "7" + > in (a,b) + +It may work to use 'hLens'' instead of 'hLens' in the second code, +but that is a bit beside the point being made here. + +The same points apply to the use of 'hPrism' over 'hLens''. + +-} + +{- | Sometimes it may be more convenient to operate on a record/variant +that only contains the fields of interest. 'projected' can then be used +to apply that function to a record that contains additional elements. + + +>>> :set -XViewPatterns +>>> import Data.HList.RecordPuns +>>> let f [pun| (x y) |] = case x+y of z -> [pun| z |] +>>> :t f +f :: Num v => + Record '[Tagged "x" v, Tagged "y" v] -> Record '[Tagged "z" v] + +>>> let r = (let x = 1; y = 2; z = () in [pun| x y z |]) +>>> r +Record{x=1,y=2,z=()} + +>>> r & sameLabels . projected %~ f +Record{x=1,y=2,z=3} + + + + +-} +class Projected r s t a b where + projected :: (ty ~ LabelableTy r, + LabeledOpticP ty p, + LabeledOpticF ty f) => r a `p` f (r b) -> r s `p` f (r t) + +-- | @Lens rs rt ra rb@ +-- +-- where @rs ~ Record s, rt ~ Record t, ra ~ Record a, rb ~ Record b@ +instance (-- for Record s -> Record a + H2ProjectByLabels (LabelsOf a) s a_ _s_minus_a, + HRLabelSet a_, HRLabelSet a, + HRearrange (LabelsOf a) a_ a, + + HLeftUnion b s bs, HRLabelSet bs, + HRearrange (LabelsOf t) bs t, HRLabelSet t + ) => Projected Record s t a b where + projected f s = (\b -> hRearrange' (b .<++. s)) <$> f (hProjectByLabels' s :: Record a) + +-- | @Prism (Variant s) (Variant t) (Variant a) (Variant b)@ +instance (ExtendsVariant b t, + ProjectVariant s a, + ProjectExtendVariant s t, + + HLeftUnion b s bs, HRLabelSet bs, + HRearrange (LabelsOf t) bs t) + => Projected Variant s t a b where + projected = prism extendsVariant + (\s -> case projectVariant s of + Just a -> Right a + Nothing | Just t <- projectExtendVariant s -> Left t + _ -> error "Data.HList.Labelable.projected impossible" + -- projectExtendVariant gives Nothing when the element of + -- `t` that is actually stored in the variant comes + -- from the `b`. But in that case the projectVariant + -- above must have been Just + ) + + +{- | @Lens' (Record s) (Record a)@ + +@Prism' (Variant s) (Variant a)@ +-} +projected' s = isSimple projected s + + +{- | Together with the instance below, this allows writing + +@ +'makeLabelable' "x y z" +p = x .*. y .*. z .*. 'emptyProxy' +@ + +Or with HListPP + +@ +p = `x .*. `y .*. `z .*. emptyProxy +@ + +instead of + +> p = Proxy :: Proxy ["x","y","z"] + +-} +instance (to ~ LabeledTo x, ToSym (to p q) x) + => HExtend (to p q) (Proxy ('[] :: [*])) where + type HExtendR (to p q) (Proxy ('[] :: [*])) = Proxy '[GetXFromLabeledTo to] + (.*.) _ _ = Proxy + +instance (to ~ LabeledTo x, ToSym (to p q) x) + => HExtend (to p q) (Proxy (x ': xs)) where + type HExtendR (to p q) (Proxy (x ': xs)) = Proxy (GetXFromLabeledTo to ': x ': xs) + (.*.) _ _ = Proxy + +-- | if the proxy has Data.HList.Label3."Lbl", then everything has to be +-- wrapped in Label to make the kinds match up. +instance (to ~ LabeledTo x, ToSym (to p q) x) + => HExtend (to p q) (Proxy (Lbl n ns desc ': xs)) where + type HExtendR (to p q) (Proxy (Lbl n ns desc ': xs)) + = Proxy (Label (GetXFromLabeledTo to) ': MapLabel (Lbl n ns desc ': xs)) + (.*.) _ _ = Proxy + +type family GetXFromLabeledTo (to :: * -> * -> *) :: Symbol +type instance GetXFromLabeledTo (LabeledTo x) = x + diff --git a/hlist/Data/HList/MakeLabels.hs b/hlist/Data/HList/MakeLabels.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/MakeLabels.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | Description : Automate some of the ways to make labels. + +-} + +module Data.HList.MakeLabels ( + makeLabels, + makeLabels3, + + -- * labels using kind 'Symbol' + makeLabels6, + makeLabelable, + ) where + +import Data.Typeable +import Data.HList.FakePrelude +import Data.HList.Label3 +import Data.HList.Labelable + +import Language.Haskell.TH +import Data.Char +import Control.Monad + +make_cname, make_dname :: String -> Name +make_cname (x:xs) = mkName ("Label" ++ toUpper x : xs) +make_cname _ = error "Data.HList.MakeLabels.make_cname: empty string" + +make_dname (x:xs) = mkName (toLower x : xs) +make_dname _ = error "Data.HList.MakeLabels.make_dname: empty string" + +dcl :: String -> Q [Dec] +dcl n = let + c = make_cname n + d = make_dname n + + dd = +#if MIN_VERSION_template_haskell(2,12,0) + dataD (return []) c [] Nothing [] [derivClause Nothing [ [t| Typeable |] ]] +#elif MIN_VERSION_template_haskell(2,11,0) + dataD (return []) c [] Nothing [] (fmap (:[]) [t| Typeable |]) +#else + dataD (return []) c [] [] [''Typeable] +#endif + + labelSig = sigD d [t| Label $(conT c) |] + + labelDec = valD + (varP d) + (normalB [| Label |]) + [] + + showInst = instanceD + (return []) + [t| Show $(conT c) |] + [valD (varP 'show) + (normalB [| \_ -> n |]) + [] ] + + in sequence [ + labelSig, + labelDec, + + dd, + + showInst ] + + +{- | + +Labels like "Data.HList.Label5". + + The following TH declaration splice should be placed at top-level, before the + created values are used. Enable @-XTemplateHaskell@ too. + +> makeLabels ["getX","getY","draw","X"] + +should expand into the following declarations + +> data LabelGetX deriving Typeable +> data LabelGetY deriving Typeable +> data LabelDraw deriving Typeable +> data LabelX deriving Typeable + +> getX = Label :: Label LabelGetX +> getY = Label :: Label LabelGetY +> draw = Label :: Label LabelDraw +> x = Label :: Label LabelX + +-} +makeLabels :: [String] -> Q [Dec] +makeLabels = fmap concat . mapM dcl + + +-- | for "Data.HList.Label3" +makeLabels3 :: String -- ^ namespace + -> [String] -- ^ labels + -> Q [Dec] +makeLabels3 ns (k:ks) = + let pt1 = fmap (concatMap (drop 2)) $ mapM dcl (ns : k : ks) + + sq1 = valD (varP (make_dname k)) + (normalB [| firstLabel (undefined :: $(conT (make_cname ns))) + (undefined :: $(conT (make_cname k))) |]) + [] + + sqs = [ valD (varP (make_dname k2)) + (normalB [| nextLabel $(varE (make_dname k1)) + (undefined :: $(conT (make_cname k2))) |]) + [] + + | (k1,k2) <- zip (k:ks) ks ] + + in fmap concat $ sequence [ pt1, sequence (sq1 : sqs) ] +-- possibly there is a better option +makeLabels3 ns [] = fail ("makeLabels3 "++ ns ++ " []") + +{- | for "Data.HList.Label6" + +> makeLabels6 ["x","y"] + +is a shortcut for + +> x = Label :: Label "x" +> y = Label :: Label "y" + +-} +makeLabels6 :: [String] -> Q [Dec] +makeLabels6 ns = fmap concat $ forM ns $ \n -> sequence + [sigD (make_dname n) [t| Label $(litT (strTyLit n)) |], + valD (varP (make_dname n)) (normalB [| Label |]) []] + + +{- | @makeLabelable \"x y z\"@ expands out to + +> x = hLens' (Label :: Label "x") +> y = hLens' (Label :: Label "y") +> z = hLens' (Label :: Label "z") + +Refer to "Data.HList.Labelable" for usage. + +-} +makeLabelable :: String -> Q [Dec] +makeLabelable xs = fmap concat $ mapM makeLabel1 (words xs) + where + -- a bit indirect, ghc-7.6 TH is a bit too eager to reject + -- mis-matched kind variables + makeLabel1 x = sequence + [ + sigD (mkName x) makeSig, + valD (varP (mkName x)) (normalB (varE 'hLens' `appE` lt)) + [] + ] + where lt = [| Label :: $([t| Label $l |]) |] + l = litT (strTyLit x) + + makeSig = [t| forall r s t a b. (Labelable $l r s t a b) => + LabeledOptic $l r s t a b + |] diff --git a/hlist/Data/HList/Record.hs b/hlist/Data/HList/Record.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Record.hs @@ -0,0 +1,1343 @@ +{-# LANGUAGE CPP #-} +{- | + The HList library + + (C) 2004-2006, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Extensible records + + The three-ish models of labels that go with this module; + + * "Data.HList.Label3" + + * "Data.HList.Label5" + + * "Data.HList.Label6" + + * "Data.HList.Labelable" + + + These used to work: + + * "Data.HList.Label1" + + * "Data.HList.Label2" + + * "Data.HList.Label4" + +-} + +module Data.HList.Record +( + -- ** labels used for doctests + -- $setup + + -- * Records + + -- ** Labels + -- $labels + module Data.Tagged, + (.=.), + + -- ** Record + Record(..), + mkRecord, + emptyRecord, + hEndR, + hEndP, + + hListRecord, hListRecord', + + -- *** Getting Labels + LabelsOf, + labelsOf, + asLabelsOf, + + -- *** Getting Values + RecordValues(..), + recordValues, + hMapTaggedFn, + + unlabeled0, + + Unlabeled, + unlabeled, + Unlabeled', + unlabeled', + + -- * Operations + -- ** Show + -- | A corresponding 'Show' instance exists as + -- + -- > show x = "Record {" ++ showComponents "" x ++ "}" + ShowComponents(..), + ShowLabel(..), + + -- ** Extension + -- | 'hExtend', 'hAppend' + (.*.), + + -- ** Delete + -- | 'hDeleteAtLabel' @label record@ + (.-.), + HDeleteLabels(..), + + -- ** Lookup/update + -- $lens + HLens(hLens), + + -- ** Lookup + HasField(..), + HasFieldM(..), + (.!.), + + -- ** Update + (.@.), + HUpdateAtLabel(hUpdateAtLabel), + -- *** type-preserving versions + -- | Note: these restrict the resulting record type to be the same as in + -- input record type, which can help reduce the number of type annotations + -- needed + (.<.), + HTPupdateAtLabel, + hTPupdateAtLabel, + + -- ** Rename Label + hRenameLabel, + + -- ** Projection + + Labels, + + -- $projection + hProjectByLabels, + hProjectByLabels', + hProjectByLabels2, + + -- *** a lens for projection + -- | see "Data.HList.Labelable".'Projected' + + -- ** Unions + -- *** Left + HLeftUnion(hLeftUnion), + (.<++.), + + -- *** Symmetric + -- $symmetricUnion + UnionSymRec(unionSR), + + + -- ** Reorder Labels + hRearrange, + hRearrange', + + -- *** isos using hRearrange + Rearranged(rearranged), rearranged', + + + -- ** Apply a function to all values + hMapR, HMapR(..), + + -- ** cast labels + Relabeled(relabeled), + relabeled', + + -- * Hints for type errors + DuplicatedLabel, + ExtraField, + FieldNotFound, + + -- * Unclassified + + -- | Probably internals, that may not be useful +#if __GLASGOW_HASKELL__ != 706 + zipTagged, +#endif + HasField'(..), + DemoteMaybe, + HasFieldM1(..), + H2ProjectByLabels(h2projectByLabels), + H2ProjectByLabels'(h2projectByLabels'), + HLabelSet, + HLabelSet', + HRLabelSet, + HAllTaggedLV, + HRearrange(hRearrange2), + HRearrange3(hRearrange3), + HRearrange4(hRearrange4), + UnionSymRec'(..), + HFindLabel, + labelLVPair, + newLVPair, + UnLabel, + HMemberLabel, + TaggedFn(..), + ReadComponent, + HMapTaggedFn, + HLensCxt, + + -- ** zip + -- | use the more general 'HZip' class instead + HZipRecord(..), + -- *** alternative implementation + hZipRecord2, hUnzipRecord2 +) where + + +import Data.HList.FakePrelude +import Data.HList.HListPrelude +import Data.HList.HList + +import Data.HList.Label3 (MapLabel) + +import Data.Tagged +import Control.Monad + +import Text.ParserCombinators.ReadP + +import LensDefs + +import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif +-- imports for doctest/examples +import Data.HList.Label6 () +import Data.HList.TypeEqO () + +{- $setup + +>>> let x = Label :: Label "x" +>>> let y = Label :: Label "y" +>>> let z = Label :: Label "z" + +-} + +-- -------------------------------------------------------------------------- + +-- $labels Record types as label-value pairs, where label is purely phantom. +-- Thus the run-time representation of a field is the same as that of +-- its value, and the record, at run-time, is indistinguishable from +-- the HList of field values. At run-time, all information about the +-- labels is erased. +-- +-- The type from "Data.Tagged" is used. + +-- | Label accessor +labelLVPair :: Tagged l v -> Label l +labelLVPair _ = Label + +newLVPair :: Label l -> v -> Tagged l v +newLVPair _ = Tagged + + + +infixr 4 .=. +{-| + + Create a value with the given label. Analagous to a data + constructor such as 'Just', 'Left', or 'Right'. Higher fixity + than record-modification operations like ('.*.'), ('.-.'), etc. to + support expression like the below w/o parentheses: + + >>> x .=. "v1" .*. y .=. '2' .*. emptyRecord + Record{x="v1",y='2'} + +-} +(.=.) :: Label l -> v -> Tagged l v +l .=. v = newLVPair l v + + +newtype Record (r :: [*]) = Record (HList r) + +deriving instance Semigroup (HList r) => Semigroup (Record r) +deriving instance Monoid (HList r) => Monoid (Record r) +deriving instance (Eq (HList r)) => Eq (Record r) +deriving instance (Ord (HList r)) => Ord (Record r) +deriving instance (Ix (HList r)) => Ix (Record r) +deriving instance (Bounded (HList r)) => Bounded (Record r) + + +-- | Build a record +mkRecord :: HRLabelSet r => HList r -> Record r +mkRecord = Record + +-- | @HRLabelSet t => Iso (HList s) (HList t) (Record s) (Record t)@ +hListRecord x = isoNewtype mkRecord (\(Record r) -> r) x + +-- | @Iso' (HList s) (Record s)@ +hListRecord' x = isSimple hListRecord x + +-- | Build an empty record +emptyRecord :: Record '[] +emptyRecord = mkRecord HNil + +-- | @Iso (Record s) (Record t) (HList a) (HList b)@ +-- +-- @view unlabeled == 'recordValues'@ +unlabeled0 x = sameLabels (iso recordValues hMapTaggedFn x) + + +unlabeled :: (Unlabeled x y, Profunctor p, Functor f) => + (HList (RecordValuesR x) `p` f (HList (RecordValuesR y))) -> + (Record x `p` f (Record y)) +unlabeled x = sameLength (unlabeled0 (sameLength x)) + +type Unlabeled x y = + (HMapCxt HList TaggedFn (RecordValuesR y) y, + RecordValues x, RecordValues y, + SameLength (RecordValuesR x) (RecordValuesR y), + SameLength x y, SameLabels x y, + HAllTaggedLV x, HAllTaggedLV y) +type Unlabeled' x = Unlabeled x x + + + +-- | @Unlabeled' x => Iso' (Record x) (HList (RecordValuesR x))@ +unlabeled' :: (Unlabeled' x, Profunctor p, Functor f) => + (HList (RecordValuesR x) `p` f (HList (RecordValuesR x))) -> + (Record x `p` f (Record x)) +unlabeled' = unlabeled + +{- | @Iso (Record s) (Record t) (Record a) (Record b)@, such that +@relabeled = unlabeled . from unlabeled@ + +in other words, pretend a record has different labels, but the same values. + +-} +class Relabeled r where + relabeled :: forall p f s t a b. + (HMapTaggedFn (RecordValuesR s) a, + HMapTaggedFn (RecordValuesR b) t, + SameLengths '[s,a,t,b], + RecordValuesR t ~ RecordValuesR b, + RecordValuesR s ~ RecordValuesR a, + RecordValues b, RecordValues s, + Profunctor p, + Functor f + ) => r a `p` f (r b) -> r s `p` f (r t) + +instance Relabeled Record where + relabeled = iso + (\ s -> hMapTaggedFn (recordValues s)) + (\ b -> hMapTaggedFn (recordValues b)) + -- isoNewtype should be safe here, but there are no guarantees + -- http://stackoverflow.com/questions/24222552 + +-- | @Iso' (Record s) (Record a)@ +-- +-- such that @RecordValuesR s ~ RecordValuesR a@ +relabeled' x = isSimple relabeled x + +data TaggedFn = TaggedFn +instance (tx ~ Tagged t x) => ApplyAB TaggedFn x tx where + applyAB _ = Tagged + +type HMapTaggedFn l r = + (HMapCxt HList TaggedFn l r, + RecordValuesR r ~ l, + RecordValues r) + +-- | \"inverse\" to 'recordValues' +hMapTaggedFn :: HMapTaggedFn a b => HList a -> Record b +hMapTaggedFn = Record . hMap TaggedFn + +-- | Property of a proper label set for a record: no duplication of labels, +-- and every element of the list is @Tagged label value@ + +data DuplicatedLabel l + +class (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*]) +instance (HLabelSet (LabelsOf ps), HAllTaggedLV ps) => HRLabelSet (ps :: [*]) + + + + +{- | Relation between HLabelSet and HRLabelSet + +> instance HLabelSet (LabelsOf ps) => HRLabelSet ps + +see also 'HSet' +-} + +class HLabelSet ls +instance HLabelSet '[] +instance HLabelSet '[x] +instance ( HEqK l1 l2 leq + , HLabelSet' l1 l2 leq r + ) => HLabelSet (l1 ': l2 ': r) + +class HLabelSet' l1 l2 (leq::Bool) r +instance ( HLabelSet (l2 ': r) + , HLabelSet (l1 ': r) + ) => HLabelSet' l1 l2 False r +instance ( Fail (DuplicatedLabel l1) ) => HLabelSet' l1 l2 True r + +-- | Construct the (phantom) list of labels of a record, +-- or list of Label. +type family LabelsOf (ls :: [*]) :: [*] +type instance LabelsOf '[] = '[] +type instance LabelsOf (Label l ': r) = Label l ': LabelsOf r +type instance LabelsOf (Tagged l v ': r) = Label l ': LabelsOf r + +labelsOf :: hlistOrRecord l -> Proxy (LabelsOf l) +labelsOf _ = Proxy + + + +-- | remove the Label type constructor. The @proxy@ argument is +-- supplied to make it easier to fix the kind variable @k@. +type family UnLabel (proxy :: k) (ls :: [*]) :: [k] +type instance UnLabel proxy (Label x ': xs) = x ': UnLabel proxy xs +type instance UnLabel proxy '[] = '[] + +-- | A version of 'HFind' where the @ls@ type variable is a list of +-- 'Tagged' or 'Label'. This is a bit indirect, and ideally LabelsOf +-- could have kind [*] -> [k]. +type HFindLabel (l :: k) (ls :: [*]) (n :: HNat) = HFind l (UnLabel l (LabelsOf ls)) n + +-- | Construct the HList of values of the record. +class SameLength r (RecordValuesR r) + => RecordValues (r :: [*]) where + type RecordValuesR r :: [*] + recordValues' :: HList r -> HList (RecordValuesR r) + +instance RecordValues '[] where + type RecordValuesR '[] = '[] + recordValues' _ = HNil +instance (SameLength' r (RecordValuesR r), + SameLength' (RecordValuesR r) r, RecordValues r) => RecordValues (Tagged l v ': r) where + type RecordValuesR (Tagged l v ': r) = v ': RecordValuesR r + recordValues' (HCons (Tagged v) r) = HCons v (recordValues' r) + +recordValues :: RecordValues r => Record r -> HList (RecordValuesR r) +recordValues (Record r) = recordValues' r + +{- shorter, but worse in terms needing annotations to allow ambiguous types +- but better in terms of inference +recordValues :: RecordValues r rv => Record r -> HList rv +recordValues (Record r) = hMap HUntag r + +type RecordValues r rv = HMapCxt HUntag r rv +-} + +-- -------------------------------------------------------------------------- + +-- 'Show' instance to appeal to normal records + +instance ShowComponents r => Show (Record r) where + show (Record r) = "Record{" + ++ showComponents "" r + ++ "}" + +class ShowComponents l where + showComponents :: String -> HList l -> String + +instance ShowComponents '[] where + showComponents _ _ = "" + +instance ( ShowLabel l + , Show v + , ShowComponents r + ) + => ShowComponents (Tagged l v ': r) where + showComponents comma (HCons f@(Tagged v) r) + = comma + ++ showLabel ((labelLVPair f) :: Label l) + ++ "=" + ++ show v + ++ showComponents "," r + + +-- -------------------------------------------------------------------------- + +-- 'Read' instance to appeal to normal records + + +data ReadComponent = ReadComponent Bool -- ^ include comma? + +instance (Read v, ShowLabel l, + x ~ Tagged l v, + ReadP x ~ y) => + ApplyAB ReadComponent (Proxy x) y where + applyAB (ReadComponent comma) _ = do + when comma (() <$ string ",") + _ <- string (showLabel (Label :: Label l)) + _ <- string "=" + v <- readS_to_P reads + return (Tagged v) + + +instance (HMapCxt HList ReadComponent (AddProxy rs) bs, + ApplyAB ReadComponent (Proxy r) readP_r, + HProxies rs, + HSequence ReadP (readP_r ': bs) (r ': rs), + readP_r ~ ReadP (Tagged l v), + + -- ghc-8.0.2 needs these. The above constraints + -- should imply them + r ~ Tagged l v, + ShowLabel l, + Read v, + HSequence ReadP bs rs + ) => Read (Record (r ': rs)) where + readsPrec _ = readP_to_S $ do + _ <- string "Record{" + content <- hSequence parsers + _ <- string "}" + return (Record content) + + where + rs :: HList (AddProxy rs) + rs = hProxies + + readP_r :: readP_r + readP_r = applyAB + (ReadComponent False) + (Proxy :: Proxy r) + + parsers = readP_r `HCons` (hMap (ReadComponent True) rs :: HList bs) + + + + + +-- -------------------------------------------------------------------------- + +-- Extension + +instance HRLabelSet (t ': r) + => HExtend t (Record r) where + type HExtendR t (Record r) = Record (t ': r) + f .*. (Record r) = mkRecord (HCons f r) + + +-- * For records + +{-| + + [@(.*.)@] + Add a field to a record. Analagous to (++) for + lists. + + > record .*. field1 + > .*. field2 + +-} + +-- -------------------------------------------------------------------------- + +-- Concatenation + +instance (HRLabelSet (HAppendListR r1 r2), HAppend (HList r1) (HList r2)) + => HAppend (Record r1) (Record r2) where + hAppend (Record r) (Record r') = mkRecord (hAppend r r') + +type instance HAppendR (Record r1) (Record r2) = Record (HAppendListR r1 r2) +-- -------------------------------------------------------------------------- + +-- Lookup +-- +-- | +-- This is a baseline implementation. +-- We use a helper class, HasField, to abstract from the implementation. + +-- | Because 'hLookupByLabel' is so frequent and important, we implement +-- it separately, more efficiently. The algorithm is familiar assq, only +-- the comparison operation is done at compile-time +class HasField (l::k) r v | l r -> v where + hLookupByLabel:: Label l -> r -> v + +{- alternative "straightforward" implementation +instance ( LabelsOf r ~ ls + , HFind l ls n + , HLookupByHNat n r + , HLookupByHNatR n r ~ LVPair l v + ) => HasField l (Record r) v + where + hLookupByLabel l (Record r) = v + where + (LVPair v) = hLookupByHNat (proxy :: Proxy n) r +-} + +{- | a version of 'HasField' / 'hLookupByLabel' / '.!.' that +returns a default value when the label is not in the record: + +>>> let r = x .=. "the x value" .*. emptyRecord + +>>> hLookupByLabelM y r () +() + +>>> hLookupByLabelM x r () +"the x value" + + + +-} +class HasFieldM (l :: k) r (v :: Maybe *) | l r -> v where + hLookupByLabelM :: Label l + -> r -- ^ Record (or Variant,TIP,TIC) + -> t -- ^ default value + -> DemoteMaybe t v + +type family DemoteMaybe (d :: *) (v :: Maybe *) :: * +type instance DemoteMaybe d (Just a) = a +type instance DemoteMaybe d Nothing = d + +class HasFieldM1 (b :: Maybe [*]) (l :: k) r v | b l r -> v where + hLookupByLabelM1 :: Proxy b -> Label l -> r -> t -> DemoteMaybe t v + +instance (HMemberM (Label l) (LabelsOf xs) b, + HasFieldM1 b l (r xs) v) => HasFieldM l (r xs) v where + hLookupByLabelM = hLookupByLabelM1 (Proxy :: Proxy b) + +instance HasFieldM1 Nothing l r Nothing where + hLookupByLabelM1 _ _ _ t = t + +instance HasField l r v => HasFieldM1 (Just b) l r (Just v) where + hLookupByLabelM1 _ l r _t = hLookupByLabel l r + + + +instance (HEqK l l1 b, HasField' b l (Tagged l1 v1 ': r) v) + => HasField l (Record (Tagged l1 v1 ': r)) v where + hLookupByLabel l (Record r) = + hLookupByLabel' (Proxy::Proxy b) l r + +-- | XXX +instance (t ~ Any, Fail (FieldNotFound l ())) => HasField l (Record '[]) t where + hLookupByLabel _ _ = error "Data.HList.Record.HasField: Fail instances should not exist" + + +class HasField' (b::Bool) (l :: k) (r::[*]) v | b l r -> v where + hLookupByLabel':: Proxy b -> Label l -> HList r -> v + +instance HasField' True l (Tagged l v ': r) v where + hLookupByLabel' _ _ (HCons (Tagged v) _) = v +instance HasField l (Record r) v => HasField' False l (fld ': r) v where + hLookupByLabel' _ l (HCons _ r) = hLookupByLabel l (Record r) + + + +infixr 9 .!. +{- | + Lookup a value in a record by its label. Analagous to (!!), the + list indexing operation. Highest fixity, like ('!!'). + + >>> :{ + let record1 = x .=. 3 .*. + y .=. 'y' .*. + emptyRecord + :} + + + >>> record1 .!. x + 3 + + >>> record1 .!. y + 'y' + + + >>> :{ + let r2 = y .=. record1 .!. x .*. + z .=. record1 .!. y .*. + emptyRecord + :} + + >>> r2 + Record{y=3,z='y'} + + Note that labels made following "Data.HList.Labelable" allow + using "Control.Lens.^." instead. +-} + + +(.!.) :: (HasField l r v) => r -> Label l -> v +r .!. l = hLookupByLabel l r + +-- -------------------------------------------------------------------------- + +-- Delete + +instance (H2ProjectByLabels '[Label l] v t1 v') + => HDeleteAtLabel Record l v v' where + hDeleteAtLabel _ (Record r) = + Record $ snd $ h2projectByLabels (Proxy::Proxy '[Label l]) r + +infixl 2 .-. +{-| + Remove a field from a record. At the same + level as other record modification options ('.*.'). Analagous + to (@\\\\@) in lists. + + > record1 .-. label1 + + > label1 .=. value1 .*. + > label2 .=. value2 .-. + > label2 .*. + > emptyRecord + + > label1 .=. value1 .-. + > label1 .*. + > label2 .=. value2 .*. + > emptyRecord + + > record1 .*. label1 .=. record2 .!. label1 + > .*. label2 .=. record2 .!. label2 + > .-. label1 + +-} +(.-.) :: (HDeleteAtLabel r l xs xs') => + r xs -> Label l -> r xs' +r .-. l = hDeleteAtLabel l r + + +-- -------------------------------------------------------------------------- + +-- Update + +-- | 'hUpdateAtLabel' @label value record@ + +class + HUpdateAtLabel record (l :: k) (v :: *) (r :: [*]) (r' :: [*]) + | l v r -> r', l r' -> v where + hUpdateAtLabel :: SameLength r r' => Label l -> v -> record r -> record r' + +instance (HUpdateAtLabel2 l v r r', + HasField l (Record r') v) => + HUpdateAtLabel Record l v r r' where + hUpdateAtLabel = hUpdateAtLabel2 + +{- alternative impl which reports a Fail constraint that is too long (the +one from HUpdateAtHNat) on ghc 7.10 RC1 + +instance (HasField l (Record r') v, + HFindLabel l r n, + HUpdateAtHNat n (Tagged l v) r, + HUpdateAtHNatR n (Tagged l v) r ~ r', + SameLength r r') => + HUpdateAtLabel Record l v r r' where + hUpdateAtLabel l v (Record r) = + Record (hUpdateAtHNat (Proxy::Proxy n) (newLVPair l v) r) +-} + +class HUpdateAtLabel2 (l :: k) (v :: *) (r :: [*]) (r' :: [*]) + | l r v -> r' where + hUpdateAtLabel2 :: Label l -> v -> Record r -> Record r' + +class HUpdateAtLabel1 (b :: Bool) (l :: k) (v :: *) (r :: [*]) (r' :: [*]) + | b l v r -> r' where + hUpdateAtLabel1 :: Proxy b -> Label l -> v -> Record r -> Record r' + +instance HUpdateAtLabel1 True l v (Tagged l e ': xs) (Tagged l v ': xs) where + hUpdateAtLabel1 _b _l v (Record (e `HCons` xs)) = Record (e{ unTagged = v } `HCons` xs) + +instance HUpdateAtLabel2 l v xs xs' => HUpdateAtLabel1 False l v (x ': xs) (x ': xs') where + hUpdateAtLabel1 _b l v (Record (x `HCons` xs)) = case hUpdateAtLabel2 l v (Record xs) of + Record xs' -> Record (x `HCons` xs') + +instance (HEqK l l' b, HUpdateAtLabel1 b l v (Tagged l' e ': xs) xs') + => HUpdateAtLabel2 l v (Tagged l' e ': xs) xs' where + hUpdateAtLabel2 = hUpdateAtLabel1 (Proxy :: Proxy b) + +-- | XXX +instance Fail (FieldNotFound l ()) => HUpdateAtLabel2 l v '[] '[] where + hUpdateAtLabel2 _ _ r = r + + +infixr 2 .@. +{-| + + Update a field with a particular value. + Same fixity as (.*.) so that extensions and updates can be chained. + There is no real list analogue, since there is no Prelude defined + update. + + > label1 .=. value1 .@. record1 + +-} +f@(Tagged v) .@. r = hUpdateAtLabel (labelLVPair f) v r + + +-- -------------------------------------------------------------------------- +-- Projection + +-- $projection +-- It is also an important operation: the basis of many +-- deconstructors -- so we try to implement it efficiently. + + +-- | @hProjectByLabels ls r@ returns @r@ with only the labels in @ls@ remaining +hProjectByLabels :: (HRLabelSet a, H2ProjectByLabels ls t a b) => + proxy ls -> Record t -> Record a +hProjectByLabels ls (Record r) = mkRecord (fst $ h2projectByLabels ls r) + +-- | See 'H2ProjectByLabels' +hProjectByLabels2 :: + (H2ProjectByLabels ls t t1 t2, HRLabelSet t1, HRLabelSet t2) => + Proxy ls -> Record t -> (Record t1, Record t2) +hProjectByLabels2 ls (Record r) = (mkRecord rin, mkRecord rout) + where (rin,rout) = h2projectByLabels ls r + +-- need to rearrange because the ordering in the result is determined by +-- the ordering in the original record, not the ordering in the proxy. In +-- other words, +-- +-- > hProjectByLabels (Proxy :: Proxy ["x","y"]) r == hProjectByLabels (Proxy :: Proxy ["y","x"]) r +hProjectByLabels' r = + let r' = hRearrange' (hProjectByLabels (labelsOf r') r) + in r' + + + +{- | A helper to make the Proxy needed by hProjectByLabels, +and similar functions which accept a list of kind [*]. + +For example: + +@(rin,rout) = 'hProjectByLabels2' (Proxy :: Labels ["x","y"]) r@ + +behaves like + +> rin = r .!. (Label :: Label "x") .*. +> r .!. (Label :: Label "y") .*. +> emptyRecord +> +> rout = r .-. (Label :: Label "x") .-. (Label :: Label "y") + +-} +type family Labels (xs :: [k]) :: * +type instance Labels xs = Proxy (Labels1 xs) + +type family Labels1 (xs :: [k]) :: [*] +type instance Labels1 '[] = '[] +type instance Labels1 (x ': xs) = Label x ': Labels1 xs + +-- | /Invariant/: +-- +-- > r === rin `disjoint-union` rout +-- > labels rin === ls +-- > where (rin,rout) = hProjectByLabels ls r +class H2ProjectByLabels (ls::[*]) r rin rout | ls r -> rin rout where + h2projectByLabels :: proxy ls -> HList r -> (HList rin,HList rout) + +instance H2ProjectByLabels '[] r '[] r where + h2projectByLabels _ r = (HNil,r) + +instance H2ProjectByLabels (l ': ls) '[] '[] '[] where + h2projectByLabels _ _ = (HNil,HNil) + +instance (HMemberM (Label l1) ((l :: *) ': ls) (b :: Maybe [*]), + H2ProjectByLabels' b (l ': ls) (Tagged l1 v1 ': r1) rin rout) + => H2ProjectByLabels (l ': ls) (Tagged l1 v1 ': r1) rin rout where + h2projectByLabels = h2projectByLabels' (Proxy::Proxy b) + +class H2ProjectByLabels' (b::Maybe [*]) (ls::[*]) r rin rout + | b ls r -> rin rout where + h2projectByLabels' :: Proxy b -> proxy ls -> + HList r -> (HList rin,HList rout) + +instance H2ProjectByLabels ls1 r rin rout => + H2ProjectByLabels' ('Just ls1) ls (f ': r) (f ': rin) rout where + h2projectByLabels' _ _ (HCons x r) = (HCons x rin, rout) + where (rin,rout) = h2projectByLabels (Proxy::Proxy ls1) r + +-- | if ls above has labels not in the record, +-- we get labels (rin `isSubsetOf` ls). +instance H2ProjectByLabels ls r rin rout => + H2ProjectByLabels' 'Nothing ls (f ': r) rin (f ': rout) where + h2projectByLabels' _ ls (HCons x r) = (rin, HCons x rout) + where (rin,rout) = h2projectByLabels ls r + +-- -------------------------------------------------------------------------- +{- | Rename the label of record + +>>> hRenameLabel x y (x .=. () .*. emptyRecord) +Record{y=()} + +-} +hRenameLabel l l' r = r'' + where + v = hLookupByLabel l r + r' = hDeleteAtLabel l r + r'' = newLVPair l' v .*. r' + + +-- -------------------------------------------------------------------------- + +type HTPupdateAtLabel record l v r = (HUpdateAtLabel record l v r r, SameLength' r r) + +-- | A variation on 'hUpdateAtLabel': type-preserving update. +hTPupdateAtLabel :: HTPupdateAtLabel record l v r => Label l -> v -> record r -> record r +hTPupdateAtLabel l v r = hUpdateAtLabel l v r + +{- ^ + +We could also say: + +> hTPupdateAtLabel l v r = hUpdateAtLabel l v r `asTypeOf` r + +Then we were taking a dependency on Haskell's type equivalence. +This would also constrain the actual implementation of hUpdateAtLabel. + +-} + +infixr 2 .<. +{-| + The same as '.@.', except type preserving. It has the same fixity as (.\@.). + +-} +f@(Tagged v) .<. r = hTPupdateAtLabel (labelLVPair f) v r + +-- -------------------------------------------------------------------------- +-- | Subtyping for records + +instance H2ProjectByLabels (LabelsOf r2) r1 r2 rout + => SubType (Record r1) (Record r2) + + +type HMemberLabel l r b = HMember l (UnLabel l (LabelsOf r)) b + +-- -------------------------------------------------------------------------- + +-- Left Union + +class HDeleteLabels ks r r' | ks r -> r' + where hDeleteLabels :: proxy (ks :: [*]) -- ^ as provided by labelsOf + -> Record r -> Record r' + +instance (HMember (Label l) ks b, + HCond b (Record r2) (Record (Tagged l v ': r2)) (Record r3), + HDeleteLabels ks r1 r2) => + HDeleteLabels ks (Tagged l v ': r1) r3 where + hDeleteLabels ks (Record (HCons lv r1)) = + case hDeleteLabels ks (Record r1) of + Record r2 -> hCond (Proxy :: Proxy b) + (Record r2) + (Record (HCons lv r2)) +instance HDeleteLabels ks '[] '[] where + hDeleteLabels _ _ = emptyRecord + + +class HLeftUnion r r' r'' | r r' -> r'' + where hLeftUnion :: Record r -> Record r' -> Record r'' + +instance (HDeleteLabels (LabelsOf l) r r', + HAppend (Record l) (Record r'), + HAppendR (Record l) (Record r') ~ (Record lr)) => HLeftUnion l r lr + where hLeftUnion l r = l `hAppend` hDeleteLabels (labelsOf l) r + + +infixl 1 .<++. +{-| + Similar to list append, so give this slightly lower fixity than + (.*.), so we can write: + + > field1 .=. value .*. record1 .<++. record2 + +-} +(.<++.) :: (HLeftUnion r r' r'') => Record r -> Record r' -> Record r'' +r .<++. r' = hLeftUnion r r' + + +-- -------------------------------------------------------------------------- +-- $symmetricUnion +-- Compute the symmetric union of two records r1 and r2 and +-- return the pair of records injected into the union (ru1, ru2). +-- +-- To be more precise, we compute the symmetric union /type/ @ru@ +-- of two record /types/ @r1@ and @r2@. The emphasis on types is important. +-- +-- The two records (ru1,ru2) in the result of 'unionSR' have the same +-- type ru, but they are generally different values. +-- Here the simple example: suppose +-- +-- > r1 = (Label .=. True) .*. emptyRecord +-- > r2 = (Label .=. False) .*. emptyRecord +-- +-- Then 'unionSR' r1 r2 will return (r1,r2). Both components of the result +-- are different records of the same type. +-- +-- +-- To project from the union ru, use 'hProjectByLabels'. +-- It is possible to project from the union obtaining a record +-- that was not used at all when creating the union. +-- +-- We do assure however that if @unionSR r1 r2@ gave @(r1u,r2u)@, +-- then projecting r1u onto the type of r1 gives the /value/ identical +-- to r1. Ditto for r2. + +class UnionSymRec r1 r2 ru | r1 r2 -> ru where + unionSR :: Record r1 -> Record r2 -> (Record ru, Record ru) + +instance (r1 ~ r1') => UnionSymRec r1 '[] r1' where + unionSR r1 _ = (r1, r1) + +instance ( HMemberLabel l r1 b + , UnionSymRec' b r1 (Tagged l v) r2' ru + ) + => UnionSymRec r1 (Tagged l v ': r2') ru + where + unionSR r1 (Record (HCons f r2')) = + unionSR' (Proxy::Proxy b) r1 f (Record r2') + +class UnionSymRec' (b :: Bool) r1 f2 r2' ru | b r1 f2 r2' -> ru where + unionSR' :: Proxy b -> Record r1 -> f2 -> Record r2' -> (Record ru, Record ru) + + + +-- | Field f2 is already in r1, so it will be in the union of r1 +-- with the rest of r2. +-- +-- To inject (HCons f2 r2) in that union, we should replace the +-- field f2 +instance (UnionSymRec r1 r2' ru, + HTPupdateAtLabel Record l2 v2 ru, + f2 ~ Tagged l2 v2) + => UnionSymRec' True r1 f2 r2' ru where + unionSR' _ r1 (Tagged v2) r2' = + case unionSR r1 r2' + of (ul,ur) -> (ul, hTPupdateAtLabel (Label :: Label l2) v2 ur) + + + +instance (UnionSymRec r1 r2' ru, + HExtend f2 (Record ru), + Record f2ru ~ HExtendR f2 (Record ru) + ) + => UnionSymRec' False r1 f2 r2' f2ru where + unionSR' _ r1 f2 r2' = (ul', ur') + where (ul,ur) = unionSR r1 r2' + ul' = f2 .*. ul + ur' = f2 .*. ur + +-- -------------------------------------------------------------------------- +-- | Rearranges a record by labels. Returns the record r, rearranged such that +-- the labels are in the order given by ls. (LabelsOf r) must be a +-- permutation of ls. +hRearrange :: (HLabelSet ls, HRearrange ls r r') => Proxy ls -> Record r -> Record r' +hRearrange ls (Record r) = Record (hRearrange2 ls r) + +{- | 'hRearrange'' is 'hRearrange' where ordering specified by the Proxy +argument is determined by the result type. + +With built-in haskell records, these @e1@ and @e2@ have the same type: + +> data R = R { x, y :: Int } +> e1 = R{ x = 1, y = 2} +> e2 = R{ y = 2, x = 1} + +'hRearrange'' can be used to allow either ordering to be accepted: + +> h1, h2 :: Record [ Tagged "x" Int, Tagged "y" Int ] +> h1 = hRearrange' $ +> x .=. 1 .*. +> y .=. 2 .*. +> emptyRecord +> +> h2 = hRearrange' $ +> y .=. 2 .*. +> x .=. 1 .*. +> emptyRecord + +-} +hRearrange' r = + let r' = hRearrange (labelsOf r') r + in r' + + +class Rearranged r s t a b where + -- @Iso (r s) (r t) (r a) (r b)@ + rearranged :: (Profunctor p, Functor f) => r a `p` f (r b) -> r s `p` f (r t) + + +{- | @Iso (Record s) (Record t) (Record a) (Record b)@ + +where @s@ is a permutation of @a@, @b@ is a permutation of @t@. +In practice 'sameLabels' and 'sameLength' are likely needed on both +sides of @rearranged@, to avoid ambiguous types. + +An alternative implementation: + +> rearranged x = iso hRearrange' hRearrange' x + +-} +instance (la ~ LabelsOf a, lt ~ LabelsOf t, + HRearrange la s a, + HRearrange lt b t, + HLabelSet la, + HLabelSet lt) + => Rearranged Record s t a b where + rearranged = iso (hRearrange (Proxy :: Proxy la)) + (hRearrange (Proxy :: Proxy lt)) + +{- | @Iso' (r s) (r a)@ + +where @s@ is a permutation of @a@ -} +rearranged' x = isSimple rearranged x + +-- | Helper class for 'hRearrange' +class (HRearrange3 ls r r', LabelsOf r' ~ ls, + SameLength ls r, SameLength r r') + => HRearrange (ls :: [*]) r r' | ls r -> r', r' -> ls where + hRearrange2 :: proxy ls -> HList r -> HList r' + + +instance (HRearrange3 ls r r', LabelsOf r' ~ ls, + SameLength ls r, SameLength r r') => HRearrange ls r r' where + hRearrange2 = hRearrange3 + +-- | same as HRearrange, except no backwards FD +class HRearrange3 (ls :: [*]) r r' | ls r -> r' where + hRearrange3 :: proxy ls -> HList r -> HList r' + +instance HRearrange3 '[] '[] '[] where + hRearrange3 _ _ = HNil + +instance (H2ProjectByLabels '[l] r rin rout, + HRearrange4 l ls rin rout r', + l ~ Label ll) => + HRearrange3 (l ': ls) r r' where + hRearrange3 _ r = hRearrange4 (Proxy :: Proxy l) (Proxy :: Proxy ls) rin rout + where (rin, rout) = h2projectByLabels (Proxy :: Proxy '[l]) r + + +-- | Helper class 2 for 'hRearrange' +class HRearrange4 (l :: *) (ls :: [*]) rin rout r' | l ls rin rout -> r' where + hRearrange4 :: proxy l -> Proxy ls -> HList rin -> HList rout -> HList r' + +instance (HRearrange3 ls rout r', + r'' ~ (Tagged l v ': r'), + ll ~ Label l) => + HRearrange4 ll ls '[Tagged l v] rout r'' where + hRearrange4 _ ls (HCons lv@(Tagged v) _HNil) rout + = HCons (Tagged v `asTypeOf` lv) (hRearrange3 ls rout) + +-- | For improved error messages. XXX FieldNotFound +instance Fail (FieldNotFound l ()) => + HRearrange4 l ls '[] rout '[] where + hRearrange4 _ _ _ _ = error "Fail has no instances" + +-- | For improved error messages +instance Fail (ExtraField l) => + HRearrange3 '[] (Tagged l v ': a) '[] where + hRearrange3 _ _ = error "Fail has no instances" + + +-- -------------------------------------------------------------------------- +-- $lens +-- Lens-based setters/getters are popular. hLens packages up +-- 'hUpdateAtLabel' and 'hLookupByLabel'. +-- +-- Refer to @examples/lens.hs@ and @examples/labelable.hs@ for examples. + +-- | constraints needed to implement 'HLens' +type HLensCxt x r s t a b = + (HasField x (r s) a, + HUpdateAtLabel r x b s t, + HasField x (r t) b, + HUpdateAtLabel r x a t s, + SameLength s t, + SameLabels s t) + +class HLensCxt x r s t a b => HLens x r s t a b + | x s b -> t, x t a -> s, -- need to repeat fundeps implied by HLensCxt + x s -> a, x t -> b where + -- | @hLens :: Label x -> Lens (r s) (r t) a b@ + hLens :: Label x -> (forall f. Functor f => (a -> f b) -> (r s -> f (r t))) + +instance HLensCxt r x s t a b => HLens r x s t a b where + hLens lab f rec = fmap (\v -> hUpdateAtLabel lab v rec) (f (rec .!. lab)) + + +{- | map over the values of a record. This is a shortcut for + + > \ f (Record a) -> Record (hMap (HFmap f) a) + +[@Example@] + +suppose we have a function that should be applied to every element +of a record: + +>>> let circSucc_ x | x == maxBound = minBound | otherwise = succ x + +>>> :t circSucc_ +circSucc_ :: (Bounded a, Enum a, Eq a) => a -> a + +Use a shortcut ('Fun') to create a value that has an appropriate 'ApplyAB' instance: + +>>> let circSucc = Fun circSucc_ :: Fun '[Eq,Enum,Bounded] '() + +Confirm that we got Fun right: + +>>> :t applyAB circSucc +applyAB circSucc :: (Bounded b, Enum b, Eq b) => b -> b + +>>> applyAB circSucc True +False + +define the actual record: + +>>> let r = x .=. 'a' .*. y .=. False .*. emptyRecord +>>> r +Record{x='a',y=False} + +>>> hMapR circSucc r +Record{x='b',y=True} + +-} +hMapR f r = applyAB (HMapR f) r + +newtype HMapR f = HMapR f + +instance (HMapCxt Record f x y, rx ~ Record x, ry ~ Record y) + => ApplyAB (HMapR f) rx ry where + applyAB (HMapR f) = hMapAux f + +instance HMapAux HList (HFmap f) x y => + HMapAux Record f x y where + hMapAux f (Record x) = Record (hMapAux (HFmap f) x) + + + +-- -------------------------------------------------------------------------- +-- | This instance allows creating a Record with +-- +-- @hBuild 3 'a' :: Record '[Tagged "x" Int, Tagged "y" Char]@ +instance (HReverse l lRev, + HMapTaggedFn lRev l') => HBuild' l (Record l') where + hBuild' l = hMapTaggedFn (hReverse l) + +-- | serves the same purpose as 'hEnd' +hEndR :: Record a -> Record a +hEndR = id + + +-- | see 'hEndP' +instance (HRevAppR l '[] ~ lRev, + HExtendRs lRev (Proxy ('[] :: [*])) ~ Proxy l1, + l' ~ l1) => HBuild' l (Proxy l') where + hBuild' _ = Proxy + +{- | @'hEndP' $ 'hBuild' label1 label2@ + +is one way to make a Proxy of labels (for use with 'asLabelsOf' +for example). Another way is + +@label1 .*. label2 .*. 'emptyProxy'@ + +-} +hEndP :: Proxy (xs :: [k]) -> Proxy xs +hEndP = id + +type family HExtendRs (ls :: [*]) (z :: k) :: k +type instance HExtendRs (l ': ls) z = HExtendR l (HExtendRs ls z) +type instance HExtendRs '[] z = z + +-- -------------------------------------------------------------------------- + +{- | + +>>> let x :: Record '[Tagged "x" Int]; x = undefined +>>> let y :: Record '[Tagged "x" Char]; y = undefined +>>> :t hZip x y +hZip x y :: Record '[Tagged "x" (Int, Char)] + +-} +instance (HZipRecord x y xy, SameLengths [x,y,xy]) + => HZip Record x y xy where + hZip = hZipRecord + +instance (HZipRecord x y xy, SameLengths [x,y,xy]) + => HUnzip Record x y xy where + hUnzip = hUnzipRecord + + +#if __GLASGOW_HASKELL__ != 706 +{- | Missing from ghc-7.6, because HZip Proxy instances interfere with HZip +HList instances. + +a variation on 'hZip' for 'Proxy', where +the list of labels does not have to include Label +(as in @ts'@) + +>>> let ts = Proxy :: Proxy ["x","y"] +>>> let ts' = Proxy :: Proxy [Label "x",Label "y"] +>>> let vs = Proxy :: Proxy [Int,Char] + +>>> :t zipTagged ts Proxy +zipTagged ts Proxy :: Proxy '[Tagged "x" y, Tagged "y" y1] + +>>> :t zipTagged ts vs +zipTagged ts vs :: Proxy '[Tagged "x" Int, Tagged "y" Char] + + +And and the case when hZip does the same thing: + +>>> :t zipTagged ts' vs +zipTagged ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char] + +>>> :t hZip ts' vs +hZip ts' vs :: Proxy '[Tagged "x" Int, Tagged "y" Char] + +-} +zipTagged :: (MapLabel ts ~ lts, + HZip Proxy lts vs tvs) + => Proxy ts -> proxy vs -> Proxy tvs +zipTagged _ _ = Proxy +#endif + + + +class HZipRecord x y xy | x y -> xy, xy -> x y where + hZipRecord :: Record x -> Record y -> Record xy + hUnzipRecord :: Record xy -> (Record x,Record y) + + +instance HZipRecord '[] '[] '[] where + hZipRecord _ _ = emptyRecord + hUnzipRecord _ = (emptyRecord, emptyRecord) + +instance HZipRecord as bs abss + => HZipRecord (Tagged x a ': as) (Tagged x b ': bs) (Tagged x (a,b) ': abss) where + hZipRecord (Record (Tagged a `HCons` as)) (Record (Tagged b `HCons` bs)) = + let Record abss = hZipRecord (Record as) (Record bs) + in Record (Tagged (a,b) `HCons` abss) + hUnzipRecord (Record (Tagged (a,b) `HCons` abss)) = + let (Record as, Record bs) = hUnzipRecord (Record abss) + in (Record (Tagged a `HCons` as), Record (Tagged b `HCons` bs)) + + +-- | instead of explicit recursion above, we could define HZipRecord in +-- terms of 'HZipList'. While all types are inferred, this implementation +-- is probably slower, so explicit recursion is used in the 'HZip' 'Record' +-- instance. +hZipRecord2 x y = hMapTaggedFn (hZipList (recordValues x) (recordValues y)) + `asLabelsOf` x `asLabelsOf` y + +hUnzipRecord2 xy = let (x,y) = hUnzipList (recordValues xy) + in (hMapTaggedFn x `asLabelsOf` xy, hMapTaggedFn y `asLabelsOf` xy) + + +{- | similar to 'asTypeOf': + +>>> let s0 = Proxy :: Proxy '["x", "y"] +>>> let s1 = Proxy :: Proxy '[Label "x", Label "y"] +>>> let s2 = Proxy :: Proxy '[Tagged "x" Int, Tagged "y" Char] + +>>> let f0 r = () where _ = r `asLabelsOf` s0 +>>> let f1 r = () where _ = r `asLabelsOf` s1 +>>> let f2 r = () where _ = r `asLabelsOf` s2 + +>>> :t f0 +f0 :: r '[Tagged "x" v, Tagged "y" v1] -> () + +>>> :t f1 +f1 :: r '[Tagged "x" v, Tagged "y" v1] -> () + +>>> :t f2 +f2 :: r '[Tagged "x" v, Tagged "y" v1] -> () + +-} +asLabelsOf :: (HAllTaggedLV x, SameLabels x y, SameLength x y) => r x -> s y -> r x +asLabelsOf = const diff --git a/hlist/Data/HList/RecordPuns.hs b/hlist/Data/HList/RecordPuns.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/RecordPuns.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoPolyKinds #-} +{- | Description : quasiquoter inspired by -XNamedFieldPuns -} +module Data.HList.RecordPuns ( + -- $ex + pun + + ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Data.HList.Record +import Data.HList.FakePrelude +import Data.List +import Data.HList.HList + +{- $ex + +>>> :set -XQuasiQuotes -XViewPatterns + +[@patterns@] + +>>> let y = Label :: Label "y" +>>> let x = Label :: Label "x" +>>> [pun| x y |] <- return (x .=. 3 .*. y .=. "hi" .*. emptyRecord) +>>> print (x,y) +(3,"hi") + +[@expressions@] + +Compare with the standard way to construct records above + +>>> let x = 3; y = "hi" +>>> [pun|x y|] +Record{x=3,y="hi"} + +[@nesting@] + +Nesting is supported. Variables inside +@{ }@ and @( )@ are one level deeper, like the built-in syntax. +Furthermore the outer @{ }@ can be left out because @[pun|{x}|]@ is more +cluttered than @[pun|x|]@. +More concretely the pattern: + + +> let [pun| ab@{ a b } y z c{d} |] = x + +is short for: + +> let ab = x.ab +> a = x.ab.a +> b = x.ab.b +> y = x.y +> z = x.z +> -- c is not bound +> d = x.c.d + +Where here `.` is a left-associative field lookup (as it is in other languages). + +The pun quasiquoter can also be used in an expression context: + +> let mkX ab a b y z d = [pun| ab@{ a b } y z c{d} |] +> x = mkX ab b y z d + +Here `mkX` includes @ab a b y z d@. @ab@ needs to be a record, and if it has +fields called @a@ or @b@ they are overridden by the values of @a@ and @b@ (via +'hLeftUnion' = '.<++.') . In other words, + +> let mkX ab_ a b y z d = let ab = [pun| a b |] .<++. ab_ +> in [pun| ab y z c{d} |] + +For patterns, any order and additional fields are allowed if @{ }@ is used, +just as in built-in record syntax. But it is often necessary to restrict the +order and number of fields, such as if the record is a 'hRearrange' of a 'hLeftUnion'. +So use @( )@ instead: + +> let [pun| (x _ y{}) |] = list +> -- desugars to something like: +> Record ((Tagged x :: Tagged "x" s1) `HCons` +> (Tagged _ :: Tagged t s2) `HCons` +> (Tagged _ :: Tagged "y" s3) `HCons` +> HNil) = list + +Note that this also introduces the familiar wild card pattern (@_@), +and shows again how to ensure a label is present but not bind a variable +to it. + +For comparison, here are three equivalent ways to define variables `x` and `y` + +> let [pun| x y{} |] = r +> let [pun|{ x y{} }|] = r -- or this +> let x = r .!. (Label :: Label "x") +> y = constrainType (r .!. (Label :: Label "y")) +> constrainType :: Record t -> Record t +> constrainType = id + +See also @examples/pun.hs@. In @{}@ patterns, @pun@ can work with +'Variant' too. + +-} + + +-- | requires labels to be promoted strings (kind Symbol), as provided by +-- "Data.HList.Label6" (ie. the label for foo is @Label :: Label \"foo\"@), +-- or "Data.HList.Labelable" +pun :: QuasiQuoter +pun = QuasiQuoter { + quotePat = suppressWarning mp . parseRec, + quoteExp = suppressWarning me . parseRec, + quoteDec = error "Data.HList.RecordPuns.quoteDec", + quoteType = error "Data.HList.RecordPuns.quoteType" + } + + +-- | the warning about @implicit {} added@ doesn't +-- make sense at top level (but it does if you say +-- have [pun| x @ y |] +suppressWarning f (V a) = f (C [V a]) +suppressWarning f x = f x + +-- extracts ["x1","x2"] becomes \x -> (x .!. x1, x .!. x2), +-- where x1 = Label :: Label "x1" +extracts xs = do + record <- newName "record" + -- to fix #5 I could comment out the ensureLength below + lamE [varP record] $ tupE + [ [| $(varE record) .!. $label |] + | x <- xs, + let label = [| Label :: Label $(litT (strTyLit x)) |], + x /= "_" + ] + +mkPair :: String -> ExpQ -> ExpQ +mkPair x xe = [| (Label :: Label $(litT (strTyLit x))) .=. $xe |] + + + +me :: Tree -> ExpQ +me (C as) = foldr (\(l,e) acc -> [| $(mkPair l e) .*. $acc |]) [| emptyRecord |] (mes as) +me (D _as) = error "Data.HList.RecordPuns.mp impossible" +me a = do + reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a + me (C [a]) + +mes :: [Tree] -> [(String, ExpQ)] +mes (V a : V "@": b : c) = (a, [| $(me b) `hLeftUnion` $(dyn a) |]) : mes c +mes (V a : C b : c) = (a, me (C b)) : mes c +mes (V a : D b : c) = (a, me (C b)) : mes c +mes (V a : b) = (a, varE (mkName a)) : mes b +mes [] = [] +mes inp = error $ "Data.HList.RecordPuns.mes: cannot translate remaining:" ++ + show (map ppTree inp) + +mp :: Tree -> PatQ +mp (C as) = + let extractPats = mps as + tupleP = tupP [ p | (binding, p) <- extractPats, binding /= "_" ] + in viewP (extracts (map fst extractPats)) tupleP + + +mp (D as) = conP 'Record + [foldr ( \ (n,p) xs -> conP 'HCons + [ let ty + | n == "_" = [| undefined :: Tagged anyLabel t |] + | otherwise = [| undefined :: Tagged $(litT (strTyLit n)) t |] + in viewP [| \x -> x `asTypeOf` $ty |] + (conP 'Tagged [p]), + xs]) + (conP 'HNil []) + (mps as)] +mp a = do + reportWarning $ "Data.HList.RecordPuns.mp implicit {} added around:" ++ show a + mp (C [a]) + +mps :: [Tree] -> [(String, PatQ)] +mps (V a : V "@" : b : c) = (a, asP (mkName a) (mp b)) : mps c +mps (V a : C b : c) = (a, mp (C b)) : mps c +mps (V a : D b : c) = (a, mp (D b)) : mps c +mps (V "_" : b) = ("_", wildP) : mps b +mps (V a : b) = (a, varP (mkName a)) : mps b +mps [] = [] +mps inp = error $ "Data.HList.RecordPuns.mps: cannot translate remaining pattern:" ++ + show (map ppTree inp) + +data Tree = C [Tree] -- ^ curly @{ }@ + | D [Tree] -- ^ @( )@ + | V String -- ^ variable + deriving Show + +{- | + +>>> parseRec "{ a b c {d e f} } d" +C [C [V "a",V "b",V "c",C [V "d",V "e",V "f"]],V "d"] + +>>> ppTree $ parseRec "{a b c {d e {} f @ g}}" +"{a b c {d e {} f @ g}}" + +>>> ppTree $ parseRec "a b c {d e {} f @ g}" +"{a b c {d e {} f @ g}}" + +>>> ppTree $ parseRec "(a b { (d) e } )" +"(a b {(d) e})" + +-} +parseRec :: String -> Tree +parseRec str = case parseRec' 0 0 [[]] $ lexing str of + [x] -> x -- avoid adding another layer if possible + x -> C (reverse x) + +parseRec' :: Int -> Int -> [[Tree]] -> [String] -> [Tree] +parseRec' n m accum ("{" : rest) = parseRec' (n+1) m ([] : accum) rest +parseRec' n m accum ("(" : rest) = parseRec' n (m+1) ([] : accum) rest +parseRec' n m (a:b:c) ("}" : rest) = parseRec' (n-1) m ((C (reverse a) : b) : c) rest +parseRec' n m (a:b:c) (")" : rest) = parseRec' n (m-1) ((D (reverse a) : b) : c) rest +parseRec' n m (b:c) (a : rest) + | a `notElem` ["{","}","(",")"] = parseRec' n m ((V a : b) : c) rest +parseRec' 0 0 (a:_) [] = a +parseRec' _ _ accum e = error ("Data.HList.RecordPuns.parseRec' unexpected: " ++ show e + ++ "\n parsed:" ++ show (reverse accum)) + +ppTree :: Tree -> String +ppTree (C ts) = "{" ++ unwords (map ppTree ts) ++ "}" +ppTree (D ts) = "(" ++ unwords (map ppTree ts) ++ ")" +ppTree (V x) = x + +lexing = unfoldr (\v -> case lex v of + ("", "") : _ -> Nothing + e : _ -> Just e + _ -> Nothing) diff --git a/hlist/Data/HList/RecordU.hs b/hlist/Data/HList/RecordU.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/RecordU.hs @@ -0,0 +1,434 @@ +{- | Description: records where elements are stored in unboxed arrays + +The public interface is exported from + +-} +module Data.HList.RecordU where + +import Data.Array.Unboxed +import Data.HList.FakePrelude +import Data.HList.Record +import Data.HList.HList + +import Data.HList.HArray +import LensDefs + +import Data.HList.Labelable + +import Unsafe.Coerce + +-- * Type definitions +-- ** RecordUS + +{- | 'RecordUS' is stored as a 'HList' of 'RecordU' +to allow the 'RecordUS' to contain elements of different +types, so long all of the types can be put into an unboxed +array ('UArray'). + +It is advantageous (at least space-wise) to sort the record to keep +elements with the same types elements adjacent. See 'SortForRecordUS' +for more details. -} +newtype RecordUS (x :: [*]) = + RecordUS Any -- ^ Any here is the @HList u@ + -- given @'RecordUSCxt' x u@ + +-- | connect the unpacked @x@ representation with the +-- corresponding list of RecordU @u@ representation. +class RecordUSCxt (x :: [*]) (u :: [*]) | x -> u, u -> x where + {- | @O(1)@ should be possible to implement this without + unsafeCoerce, but we want to hide the @u@ parameter _and_ + keep the RecordUSCxt as a class (instead of a type + family) because of 'HEq'. In some cases it is possible + to have instances that do not actually respect the functional + dependency, but this should be safe if the check is not + disabled (by using @-XDysfunctionalDependencies@ + , or ghc-7.6) -} + recordUSToHList :: RecordUS x -> HList u + recordUSToHList (RecordUS x) = unsafeCoerce x + + -- | @O(1)@ should be possible to implement this without + -- unsafeCoerce + hListToRecordUS :: HList u -> RecordUS x + hListToRecordUS x = RecordUS (unsafeCoerce x) + +-- | the only instance +instance (HGroupBy EqTagValue x g, HMapUnboxF g u) => RecordUSCxt x u + +data EqTagValue +instance HEqByFn EqTagValue +instance (txv ~ Tagged x v, + tyw ~ Tagged y w, + HEq v w b) => HEqBy EqTagValue txv tyw b + +-- | proof that @'hMap' 'UnboxF' :: r xs -> r us@ can determine +-- @xs@ from @us@ and @us@ from @xs@ +class HMapUnboxF (xs :: [*]) (us :: [*]) | xs -> us, us -> xs +instance HMapUnboxF '[] '[] +instance HMapUnboxF xs us => HMapUnboxF (HList x ': xs) (RecordU x ': us) + + +instance (RecordUSCxt x u, Show (HList u)) => Show (RecordUS x) where + showsPrec n r = ("RecordUS " ++) . showsPrec n (recordUSToHList r) + +-- ** RecordU + +{- | A type which behaves similarly to 'Record', except +all elements must fit in the same 'UArray'. A consequence of +this is that @RecordU@ has the following properties: + +* it is strict in the element types + +* it cannot do type-changing updates of 'RecordU', except if + the function applies to all elements + +* it probably is slower to update the very first elements + of the 'RecordU' + +The benefit is that lookups should be faster and records +should take up less space. However benchmarks done with +a slow 'HNat2Integral' do not suggest that RecordU is +faster than Record. +-} +newtype RecordU l = RecordU (UArray Int (GetElemTy l)) + +type family GetElemTy (x :: [*]) :: * +type instance GetElemTy (Tagged label v ': rest) = v + +deriving instance (Show (UArray Int (GetElemTy l))) => Show (RecordU l) +deriving instance (Read (UArray Int (GetElemTy l))) => Read (RecordU l) +deriving instance (Eq (UArray Int (GetElemTy l))) => Eq (RecordU l) +deriving instance (Ord (UArray Int (GetElemTy l))) => Ord (RecordU l) + +{- | Reorders a 'Record' such that the 'RecordUS' made from it takes up +less space + +'Bad' has alternating Double and Int fields + +>>> bad +Record{x=1.0,i=2,y=3.0,j=4} + +4 arrays containing one element each are needed when this +Record is stored as a RecordUS + +>>> recordToRecordUS bad +RecordUS H[RecordU (array (0,0) [(0,1.0)]),RecordU (array (0,0) [(0,2)]),RecordU (array (0,0) [(0,3.0)]),RecordU (array (0,0) [(0,4)])] + +It is possible to sort the record + +>>> sortForRecordUS bad +Record{x=1.0,y=3.0,i=2,j=4} + +This allows the same content to be stored in +two unboxed arrays + +>>> recordToRecordUS (sortForRecordUS bad) +RecordUS H[RecordU (array (0,1) [(0,1.0),(1,3.0)]),RecordU (array (0,1) [(0,2),(1,4)])] + +-} +class SortForRecordUS x x' | x -> x' where + sortForRecordUS :: Record x -> Record x' + +instance SortForRecordUS '[] '[] where + sortForRecordUS = id + +instance (HPartitionEq EqTagValue x (x ': xs) xi xo, + SortForRecordUS xo xo', + sorted ~ HAppendListR xi xo', + HAppendList xi xo') => + SortForRecordUS (x ': xs) sorted where + sortForRecordUS (Record xs) = Record (hAppendList xi xo') + where + f = Proxy :: Proxy EqTagValue + x1 = Proxy :: Proxy x + (xi,xo) = hPartitionEq f x1 xs + Record xo' = sortForRecordUS (Record xo) + +-------------------------------------------------------------- +-- * Lookup + +-- | works expected. See examples attached to 'bad'. +instance (HFindLabel l r n, + HLookupByHNatUS n u (Tagged l v), + HasField l (Record r) v, + RecordUSCxt r u) => + HasField l (RecordUS r) v where + hLookupByLabel _ u = case hLookupByHNatUS n (recordUSToHList u) of Tagged v -> v + where n = Proxy :: Proxy n + +class HLookupByHNatUS (n :: HNat) (us :: [*]) (e :: *) | n us -> e where + hLookupByHNatUS :: Proxy n -> HList us -> e + +class HLookupByHNatUS1 (r :: Either HNat HNat) (n :: HNat) (u :: [*]) (us :: [*]) (e :: *) + | r n u us -> e where + hLookupByHNatUS1 :: Proxy r -> Proxy n -> RecordU u -> HList us -> e + +instance (r ~ HSubtract (HLength u) n, + RecordU u ~ ru, + HLookupByHNatUS1 r n u us e) => + HLookupByHNatUS n (ru ': us) e where + hLookupByHNatUS n (HCons u us) = hLookupByHNatUS1 (Proxy :: Proxy r) n u us + +instance (HNat2Integral n, + HLookupByHNatR n u ~ le, + le ~ Tagged l e, + IArray UArray e, + e ~ GetElemTy u) => HLookupByHNatUS1 (Left t) n u us le where + hLookupByHNatUS1 _ n (RecordU u) _us = Tagged (u ! hNat2Integral n) + +instance HLookupByHNatUS t us e => HLookupByHNatUS1 (Right t) n u us e where + hLookupByHNatUS1 _ _ _ = hLookupByHNatUS (Proxy :: Proxy t) + +-- | @HSubtract a b@ is @Left (a-b)@, @Right (b-a)@ or @Right HZero@ +type family HSubtract (n1 :: HNat) (n2 :: HNat) :: Either HNat HNat + +type instance HSubtract HZero HZero = Right HZero +type instance HSubtract (HSucc x) (HSucc y) = HSubtract x y +type instance HSubtract HZero (HSucc y) = Right (HSucc y) +type instance HSubtract (HSucc y) HZero = Left (HSucc y) + + + + +-------------------------------------------------------------- +-- * Conversion of RecordUS + +-- ** with the actual representation + +-- | @Iso (HList s) (HList t) (RecordUS a) (RecordUS b)@ +recordUS r = iso hListToRecordUS recordUSToHList r + +{- | @Iso (HList s) (RecordUS a)@ + +@s@ is a HList of 'RecordU' while @a :: [*]@ +is list of @Tagged label value@ + +-} +recordUS' r = isSimple recordUS r + +-- ** with 'Record' + +-- | @view unboxedS@ or @^. unboxedS@ are preferred +recordToRecordUS :: forall x g u. + (HMapCxt HList UnboxF g u, + HMapUnboxF g u, + HGroupBy EqTagValue x g, + RecordUSCxt x u) + => Record x -> RecordUS x +recordToRecordUS (Record x) = hListToRecordUS u + where + u :: HList u + u = hMap UnboxF g + + g :: HList g + g = hGroupBy (Proxy :: Proxy EqTagValue) x + +-- | @^. from unboxedS@ is preferred +recordUSToRecord :: forall u g x. + (HConcatFD g x, + HMapCxt HList BoxF u g, + HMapUnboxF g u, + RecordUSCxt x u + ) => RecordUS x -> Record x +recordUSToRecord rus = Record (hConcatFD g) + where + g :: HList g + g = hMap BoxF (recordUSToHList rus) + +-- | @Iso (Record x) (Record y) (RecordUS x) (RecordUS y)@ +unboxedS r = iso recordToRecordUS recordUSToRecord r + +-- | @Iso' (Record x) (RecordUS x)@ +unboxedS' r = isSimple unboxedS r + + + +-- | all elements of the list have the same type +class ElemTyEq (xs :: [*]) + +instance + (t1v ~ Tagged t1 v, + t2v ~ Tagged t2 v, + ElemTyEq (tv2 ': rest)) => + ElemTyEq (tv1 ': tv2 ': rest) + +instance t1v ~ Tagged t v => ElemTyEq (t1v ': rest) +instance ElemTyEq '[] + + +instance (IArray UArray v, + v ~ GetElemTy ls, + HFindLabel l ls n, + HNat2Integral n) + => HasField l (RecordU ls) v where + hLookupByLabel _ (RecordU ls) = ls ! hNat2Integral (Proxy :: Proxy n) + + +instance (r ~ r', + v ~ GetElemTy r, + HFindLabel l r n, + HNat2Integral n, + IArray UArray v, + HasField l (Record r') v) + => HUpdateAtLabel RecordU l v r r' where + hUpdateAtLabel _ v (RecordU r) = RecordU (r // [(hNat2Integral (Proxy :: Proxy n), v)]) + + +{- | analogous flip '//'. Similar to '.<++.', except it is restricted +to cases where the left argument holds a subset of elements. + +-} +class HUpdateMany lv rx where + hUpdateMany :: Record lv -> rx -> rx + +instance (RecordValues lv, + HList2List (RecordValuesR lv) v, + HFindMany (LabelsOf lv) (LabelsOf r) ixs, + IArray UArray v, + v ~ GetElemTy r, + HNats2Integrals ixs) => + HUpdateMany lv (RecordU r) where + hUpdateMany lv (RecordU r) = RecordU (r // (zip ixs (hList2List (recordValues lv)))) + where ixs = hNats2Integrals (Proxy :: Proxy ixs) + +-- | implementation in terms of '.<++.' +instance (HLeftUnion lv x lvx, + HRLabelSet x, + HLabelSet (LabelsOf x), + HRearrange (LabelsOf x) lvx x) + => HUpdateMany lv (Record x) where + hUpdateMany lv x = hRearrange' (lv .<++. x) + +-- | behaves like @map 'HFind'@ +class HFindMany (ls :: [k]) (r :: [k]) (ns :: [HNat]) | ls r -> ns +instance (HFind l r n, + HFindMany ls r ns) => HFindMany (l ': ls) r (n ': ns) + +instance HFindMany '[] r '[] + +instance (ApplyAB f (GetElemTy x) (GetElemTy y), + IArray UArray (GetElemTy y), + IArray UArray (GetElemTy x)) => HMapAux RecordU f x y where + hMapAux f (RecordU x) = RecordU (amap (applyAB f) x) + +-- | 'hMap' specialized to 'RecordU' +hMapRU :: HMapCxt RecordU f x y => f -> RecordU x -> RecordU y +hMapRU f = hMap f + + +-- | @Iso (Record x) (Record y) (RecordU x) (RecordU y)@ +unboxed :: forall x y f p. + (Profunctor p, + Functor f, + RecordToRecordU x, + RecordUToRecord y) + => RecordU x `p` f (RecordU y) + -> Record x `p` f (Record y) +unboxed r = iso recordToRecordU recordUToRecord r + +-- | @Iso' (Record x) (RecordU x)@ +unboxed' x = isSimple unboxed x + + +class RecordToRecordU x where + recordToRecordU :: Record x -> RecordU x + +instance ( + RecordValues x, + HList2List (RecordValuesR x) (GetElemTy x), + HNat2Integral n, + HLengthEq x n, + IArray UArray (GetElemTy x) + ) => RecordToRecordU x where + recordToRecordU (rx@(Record x)) = RecordU $ listArray + (0, hNat2Integral (hLength x) - 1) + (hList2List (recordValues rx)) + +class RecordUToRecord x where + recordUToRecord :: RecordU x -> Record x + +instance ( + HMapCxt HList TaggedFn (RecordValuesR x) x, + IArray UArray (GetElemTy x), + HList2List (RecordValuesR x) (GetElemTy x) + ) => RecordUToRecord x where + recordUToRecord (RecordU b) = case list2HList $ elems b of + Nothing -> error "Data.HList.RecordU.recordUToRecord impossibly too few elements" + Just y0 -> Record $ hMap TaggedFn (y0 :: HList (RecordValuesR x)) + + + +-- * definitions for doctest examples +type Bad = + [Tagged "x" Double, + Tagged "i" Int, + Tagged "y" Double, + Tagged "j" Int] + +{- | HasField instances + +[@RecordUS@] + +>>> let r = recordToRecordUS (sortForRecordUS bad) +>>> let s = recordToRecordUS bad + +>>> let x = Label :: Label "x" +>>> let y = Label :: Label "y" +>>> let i = Label :: Label "i" +>>> let j = Label :: Label "j" + +>>> (r .!. x, r .!. i, r .!. y, r .!. j) +(1.0,2,3.0,4) + +>>> (s .!. x, s .!. i, s .!. y, s .!. j) +(1.0,2,3.0,4) + + +[@RecordU@] + +>>> let t = recordToRecordU bad1 +>>> (t .!. x, t .!. y) +(1.0,2.0) + +>>> hUpdateAtLabel x 3 t .!. x +3.0 + +-} +bad :: Record Bad +bad = Tagged 1 .*. Tagged 2 .*. Tagged 3 .*. Tagged 4 .*. emptyRecord + +bad1 :: Record [Tagged "x" Double, Tagged "y" Double] +bad1 = Tagged 1 .*. Tagged 2 .*. emptyRecord + +-- * Implementation Details + +data UnboxF = UnboxF +instance (hx ~ HList x, ux ~ RecordU x, + RecordToRecordU x) => + ApplyAB UnboxF hx ux where + applyAB _ = recordToRecordU . Record + +data BoxF = BoxF + +instance (ux ~ RecordU x, + hx ~ HList x, + RecordUToRecord x) => + ApplyAB BoxF ux hx where + applyAB _ ux = case recordUToRecord ux of Record hx -> hx + + +-- | make a @Lens' (RecordU s) a@ +instance (s ~ t, a ~ b, + IArray UArray a, a ~ GetElemTy s, + HLensCxt x RecordU s t a b) + => Labelable x RecordU s t a b where + type LabelableTy RecordU = LabelableLens + hLens' x = hLens x + +{- TODO +instance Labelable x RecordUS to p f s t a b where +instance (r ~ r', HasField l (Record r) v) + => HUpdateAtLabel RecordUS l v r r' where + hUpdateAtLabel = error "recordus hupdateatlabel" + +Benchmarks +-} diff --git a/hlist/Data/HList/TIC.hs b/hlist/Data/HList/TIC.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/TIC.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE CPP #-} + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Type-indexed co-products. The public interface is exposed + in + + (There are other ways: see ConsUnion.hs, for example) +-} + +module Data.HList.TIC where + +import Data.HList.TIP +import Data.HList.FakePrelude +import Data.HList.HListPrelude + +import Data.HList.Record +import Data.HList.Variant +import Data.HList.HList + +import Data.HList.HArray + +import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif +import Text.ParserCombinators.ReadP +import LensDefs + +-- -------------------------------------------------------------------------- +-- | A datatype for type-indexed co-products. A 'TIC' is just a 'Variant', +-- where the elements of the type-level list @\"l\"@ are in the form +-- @Tagged x x@. + +newtype TIC (l :: [*]) = TIC (Variant l) + +deriving instance Eq (Variant l) => Eq (TIC l) +deriving instance Ord (Variant l) => Ord (TIC l) +deriving instance Ix (Variant l) => Ix (TIC l) +deriving instance Bounded (Variant l) => Bounded (TIC l) +deriving instance Enum (Variant l) => Enum (TIC l) +deriving instance Monoid (Variant l) => Monoid (TIC l) +deriving instance Semigroup (Variant l) => Semigroup (TIC l) + + +instance HMapAux Variant f xs ys => HMapAux TIC f xs ys where + hMapAux f (TIC a) = TIC (hMapAux f a) + +-- | @Iso (TIC s) (TIC t) (Variant s) (Variant t)@ +-- +-- 'typeIndexed' may be more appropriate +ticVariant x = isoNewtype (\(TIC a) -> a) TIC x + +-- | @Iso' (TIC s) (Variant s)@ +ticVariant' x = isSimple ticVariant x + + +-- -------------------------------------------------------------------------- + +{- | Conversion between type indexed collections ('TIC' and 'TIP') +and the corresponding collection that has other label types ('Variant' +and 'Record' respectively) + +See 'typeIndexed'' + +-} +class TypeIndexed r tr | r -> tr, tr -> r where + -- | @Iso (r s) (r t) (tr a) (tr b)@ + typeIndexed :: forall p f s t a b. + (TypeIndexedCxt s t a b, Profunctor p, Functor f) => + p (tr (TagR a)) (f (tr (TagR b))) -> p (r s) (f (r t)) + +type TypeIndexedCxt s t a b = + (HMapCxt HList TaggedFn b t, + RecordValues s, RecordValues t, + a ~ RecordValuesR s, + b ~ RecordValuesR t, + SameLabels s t, + SameLength s t, + SameLength b a, + {- to use castVariant instead of unsafeCastVariant + RecordValuesR (TagR a) ~ a, + RecordValuesR (TagR b) ~ b, + SameLength (TagR a) s, + SameLength (TagR b) t, + -} + Coercible (TagR b) t, + Coercible (TagR a) s, + HAllTaggedLV s, + HRLabelSet t, + TagUntag a, + TagUntag b) + +instance TypeIndexed Record TIP where + typeIndexed = sameLength . unlabeled . fromTipHList + where fromTipHList = iso (TIP . hTagSelf) (\(TIP a) -> hUntagSelf a) + +instance TypeIndexed Variant TIC where + typeIndexed = isoNewtype unsafeCastVariant unsafeCastVariant + . isoNewtype TIC (\(TIC a) -> a) + +{- | + +@'Iso'' ('Variant' s) ('TIC' a)@ + +@'Iso'' ('Record' s) ('TIP' a)@ + +where @s@ has a type like @'[Tagged \"x\" Int]@, and +@a@ has a type like @'[Tagged Int Int]@. +-} +typeIndexed' x = isSimple typeIndexed x + +-- -------------------------------------------------------------------------- +-- | Public constructor (or, open union's injection function) + +mkTIC' :: forall i l proxy. + ( HTypeIndexed l + , MkVariant i i l + ) + => i + -> proxy l -- ^ the ordering of types in the @l :: [*]@ matters. + -- This argument is intended to fix the ordering + -- it can be a Record, Variant, TIP, Proxy + -> TIC l + +mkTIC' i p = TIC (mkVariant (Label :: Label i) i p) + +-- | make a TIC that contains one element +mkTIC1 :: forall i. MkVariant i i '[Tagged i i] => i -> TIC '[Tagged i i] +mkTIC1 i = TIC (mkVariant1 (Label :: Label i) i) + +-- | make a TIC for use in contexts where the result type is fixed +mkTIC i = mkTIC' i Proxy + + +-- -------------------------------------------------------------------------- +-- | Public destructor (or, open union's projection function) +instance HasField o (Variant l) (Maybe o) => + HasField o (TIC l) (Maybe o) where + hLookupByLabel l (TIC i) = hLookupByLabel l i + + +instance (HasField o (TIC l) mo, mo ~ Maybe o) => HOccurs mo (TIC l) where + hOccurs = hLookupByLabel (Label :: Label o) + + +-- | similar to 'HPrism' +class TICPrism s t a b | s a b -> t, t a b -> s where + ticPrism :: (SameLength s t, Choice p, Applicative f) + => (a `p` f b) -> (TIC s `p` f (TIC t)) + +instance ( + MkVariant b b t, + HasField a (Variant s) (Maybe a), + SameLength s t, + + HFindLabel b t n, + HFindLabel a s n, + + HUpdateAtHNatR n (Tagged b b) s ~ t, + HUpdateAtHNatR n (Tagged a a) t ~ s + + ) => TICPrism s t a b where + ticPrism = ticVariant . prism (\b -> mkVariant (Label :: Label b) b Proxy) + (\s -> case hLookupByLabel (Label :: Label a) s of + Just a -> Right a + Nothing -> Left (unsafeCastVariant s :: Variant t)) + +-- | @Prism' (TIC s) a@ +ticPrism' :: forall s t a b. (HPrism a s t a b, a~b, s~t) + => (forall f p. (Applicative f, Choice p) => (a `p` f b) -> (TIC s `p` f (TIC t))) +ticPrism' = ticVariant . hPrism (Label :: Label a) + + +-- -------------------------------------------------------------------------- +-- | TICs are not opaque + +instance ShowVariant l => Show (TIC l) + where + showsPrec _ (TIC v) = ("TIC{"++) . showVariant v . ('}':) + + +instance (ReadVariant l, HAllTaggedEq l, HRLabelSet l) => Read (TIC l) + where + readsPrec _ = readP_to_S $ do + _ <- string "TIC{" + r <- readVariant + _ <- string "}" + return (TIC r) + + +{- | +> Nothing .*. x = x +> Just a .*. y = mkTIC a +-} +instance (me ~ Maybe e, HOccursNot (Tagged e e) l) + => HExtend me (TIC l) where + type HExtendR me (TIC l) = TIC (Tagged (UnMaybe me) (UnMaybe me) ': l) + Just e .*. _ = TIC (unsafeMkVariant 0 e) + Nothing .*. TIC x = TIC (extendVariant x) diff --git a/hlist/Data/HList/TIP.hs b/hlist/Data/HList/TIP.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/TIP.hs @@ -0,0 +1,560 @@ +{-# LANGUAGE CPP #-} + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Type-indexed products. + The public interface is described in + +-} + +module Data.HList.TIP + (module Data.HList.TIPtuple, + module Data.HList.TIP) where + + +import Data.HList.HListPrelude +import Data.HList.FakePrelude +import Data.HList.HList +import Data.HList.Record +import Data.HList.HTypeIndexed () +import Data.HList.TIPtuple +import Data.List (intercalate) +import Data.Array (Ix) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup) +#endif + +#if __GLASGOW_HASKELL__ > 710 +import Data.Coerce +#endif + +import LensDefs + +-- -------------------------------------------------------------------------- +-- * The newtype for type-indexed products + +-- | TIPs are like 'Record', except element \"i\" of the list \"l\" +-- has type @Tagged e_i e_i@ +newtype TIP (l :: [*]) = TIP{unTIP:: HList l} + +deriving instance Semigroup (HList a) => Semigroup (TIP a) +deriving instance Monoid (HList a) => Monoid (TIP a) +deriving instance Eq (HList a) => Eq (TIP a) +deriving instance (Ord (HList r)) => Ord (TIP r) +deriving instance (Ix (HList r)) => Ix (TIP r) +deriving instance (Bounded (HList r)) => Bounded (TIP r) + + +instance HMapOut (HShow `HComp` HUntag) l String => Show (TIP l) where + showsPrec _ (TIP l) = ("TIPH[" ++) + . (intercalate "," (hMapOut (HShow `HComp` HUntag) l) ++) + . (']' :) + + +mkTIP :: HTypeIndexed l => HList l -> TIP l +mkTIP = TIP + +emptyTIP :: TIP '[] +emptyTIP = mkTIP HNil + +-- -------------------------------------------------------------------------- +-- * Type-indexed type sequences + +-- | this constraint ensures that a TIP created by 'mkTIP' has no +-- duplicates +class (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed (l :: [*]) + +instance (HAllTaggedEq l, HRLabelSet l) => HTypeIndexed l + +class HAllTaggedEq (l :: [*]) +instance HAllTaggedEq '[] +instance (HAllTaggedEq l, tee ~ Tagged e e') => HAllTaggedEq (tee ': l) + +-- -------------------------------------------------------------------------- +-- Implementing the HListPrelude interface + +instance (HRLabelSet (Tagged e e ': l), HTypeIndexed l) => HExtend e (TIP l) + where + type HExtendR e (TIP l) = TIP (Tagged e e ': l) + e .*. TIP l = mkTIP (HCons (Tagged e) l) + + + +instance (e ~ e', HasField e (Record l) e') => HasField e (TIP l) e' where + hLookupByLabel lab (TIP l) = hLookupByLabel lab (Record l) + +-- | One occurrence and nothing is left +-- +-- This variation provides an extra feature for singleton lists. +-- That is, the result type is unified with the element in the list. +-- Hence the explicit provision of a result type can be omitted. +-- + +instance (tee ~ Tagged e e) => HOccurs e (TIP '[tee]) where + hOccurs (TIP (HCons (Tagged e) _)) = e + +instance HasField e (Record (x ': y ': l)) e + => HOccurs e (TIP (x ': y ': l)) where + hOccurs (TIP l) = Record l .!. (Label :: Label e) + + +instance (HAppend (HList l) (HList l'), HTypeIndexed (HAppendListR l l')) + => HAppend (TIP l) (TIP l') + where + hAppend (TIP l) (TIP l') = mkTIP (hAppend l l') + +type instance HAppendR (TIP l) (TIP l') = TIP (HAppendListR l l') + + +-- instance HOccurrence HList e l l' => HOccurrence TIP e l l' +-- where +-- hOccurrence e = TIP . hOccurrence e . unTIP + +-- -------------------------------------------------------------------------- +-- * Shielding type-indexed operations +-- $note The absence of signatures is deliberate! They all must be inferred. + +onRecord f (TIP l) = let Record l' = f (Record l) in mkTIP l' + +instance (HDeleteAtLabel Record e v v', + HTypeIndexed v') + => HDeleteAtLabel TIP e v v' where + hDeleteAtLabel e v = onRecord (hDeleteAtLabel e) v + + +tipyUpdate e t = hTPupdateAtLabel (fromValue e) e t + where fromValue :: e -> Label e + fromValue _ = Label + +instance (HUpdateAtLabel Record e' e r r', + HTypeIndexed r', + e ~ e') => HUpdateAtLabel TIP e' e r r' where + hUpdateAtLabel l e r = onRecord (hUpdateAtLabel l e) r + + +-- | Use 'Labels' to specify the first argument +tipyProject ps t = onRecord (hProjectByLabels ps) t + +-- | provides a @Lens' (TIP s) a@. 'hLens'' @:: Label a -> Lens' (TIP s) a@ +-- is another option. +#if __GLASGOW_HASKELL__ < 707 +tipyLens' x = isSimple tipyLens x -- rejected by GHC-7.10RC1 +#else +tipyLens' f s = isSimple (hLens x) f (asTIP s) -- rejected by GHC-7.6.3 + where + x = getA f + getA :: (a -> f a) -> Label a + getA _ = Label + + asTIP :: TIP a -> TIP a + asTIP = id +#endif + +{- | provides a @Lens (TIP s) (TIP t) a b@ + +When using @set@ (also known as @.~@), 'tipyLens'' can address the +ambiguity as to which field \"a\" should actually be updated. + +-} +tipyLens f (TIP s) = + case hSplitAt (getN s f) (ghc8fix1 s) of + (x, ta@(Tagged a) `HCons` ys) + | () <- ghc8fix2 ta -> + let mkt b = mkTIP (x `hAppendList` (tagSelf b `HCons` ys)) + in mkt <$> f a + where + getN :: HFind (Label a) (LabelsOf s) n => HList s -> (a -> f b) -> Proxy n + getN _ _ = Proxy + + -- without these, tipyLens has a type that has kind variables, + -- (that end up being * when an actual TIP is provided), leading to + -- a Properties.LengthIndependent compile error: + -- .../.stack-work/dist/x86_64-linux/Cabal-1.24.2.0/build/Data/HList/TIP.hi + -- Declaration for tipyLens: + -- Iface type variable out of scope: k + -- Cannot continue after interface file error + ghc8fix1 :: HList (Tagged x x ': xs) -> HList (Tagged x x ': xs) + ghc8fix1 = id + + ghc8fix2 :: Tagged a a -> () + ghc8fix2 _ = () + + + +-- | The same as 'tipyProject', except also return the +-- types not requested in the @proxy@ argument +tipyProject2 ps (TIP l) = (mkTIP l',mkTIP l'') + where + (l',l'') = h2projectByLabels ps l + + +-- -------------------------------------------------------------------------- + +-- | Subtyping for TIPs + +instance SubType (TIP l) (TIP '[]) +instance (HOccurs e (TIP l1), SubType (TIP l1) (TIP l2)) + => SubType (TIP l1) (TIP (e ': l2)) + + +-- -------------------------------------------------------------------------- +-- * conversion to and from 'HList' + +{- | 'TagR' can also be used to avoid redundancy when defining types for TIC and TIP. + +> type XShort = TagR [A,B,C,D] + +> type XLong = [Tagged A A, Tagged B B, Tagged C C, Tagged D D] + + +an equivalent FD version, which is slightly better with respect to +simplifying types containing type variables (in ghc-7.8 and 7.6): + + +With ghc-7.10 () the FD version is superior +to the TF version: + +@ +class (UntagR (TagR a) ~ a) => TagUntag a where + type TagR a :: [*] + hTagSelf :: HList a -> HList (TagR a) + hUntagSelf :: HList (TagR a) -> HList a + +instance TagUntag '[] where + type TagR '[] = '[] + hTagSelf _ = HNil + hUntagSelf _ = HNil + +instance TagUntag xs => TagUntag (x ': xs) where + type TagR (x ': xs) = Tagged x x ': TagR xs + hTagSelf (HCons x xs) = Tagged x `HCons` hTagSelf xs + hUntagSelf (HCons (Tagged x) xs) = x `HCons` hUntagSelf xs + +type family UntagR (xs :: [*]) :: [*] +type instance UntagR '[] = '[] +type instance UntagR (x ': xs) = Untag1 x ': UntagR xs +@ + +Length information should flow backwards + +>>> let len2 x = x `asTypeOf` (undefined :: HList '[a,b]) +>>> let f = len2 $ hTagSelf (hReplicate Proxy ()) +>>> :t f +f :: HList '[Tagged () (), Tagged () ()] + +-} +class SameLength a ta => TagUntagFD a ta | a -> ta, ta -> a where + hTagSelf :: HList a -> HList ta + hUntagSelf :: HList ta -> HList a + +instance TagUntagFD '[] '[] where + hTagSelf _ = HNil + hUntagSelf _ = HNil + +instance (TagUntagFD xs ys, txx ~ Tagged x x) + => TagUntagFD (x ': xs) (txx ': ys) where + hTagSelf (HCons x xs) = Tagged x `HCons` hTagSelf xs + hUntagSelf (HCons (Tagged x) xs) = x `HCons` hUntagSelf xs + +type TagUntag xs = TagUntagFD xs (TagR xs) + +-- | Sometimes the type variables available have @TagR@ already applied +-- (ie the lists have elements like @Tagged X X@). Then this abbreviation +-- is useful: +type UntagTag xs = (TagR (UntagR xs) ~ xs, TagUntagFD (UntagR xs) xs) + +type family TagR (a :: [*]) :: [*] +type family UntagR (ta :: [*]) :: [*] + +type instance TagR '[] = '[] +type instance UntagR '[] = '[] + +type instance TagR (x ': xs) = Tagged x x ': TagR xs +type instance UntagR (Tagged y y ': ys) = y ': UntagR ys + +type family Untag1 (x :: *) :: * +type instance Untag1 (Tagged k x) = x + + +-- | @Iso (TIP (TagR a)) (TIP (TagR b)) (HList a) (HList b)@ +tipHList x = iso (\(TIP a) -> hUntagSelf a) (TIP . hTagSelf) x + +-- | @Iso' (TIP (TagR s)) (HList a)@ +tipHList' x = isSimple tipHList x + + +-- * conversion to and from 'Record' + +-- | @Iso (TIP s) (TIP t) (Record s) (Record t)@ +-- +-- 'typeIndexed' may be more appropriate +tipRecord x = isoNewtype (\(TIP a) -> Record a) (\(Record b) -> TIP b) x + +-- | @Iso' (TIP (TagR s)) (Record a)@ +tipRecord' x = isSimple tipRecord x + +-- -------------------------------------------------------------------------- +-- * Zip + +#if __GLASGOW_HASKELL__ < 800 +-- pre-coerce +instance (HZipList (UntagR x) (UntagR y) (UntagR xy), + UntagTag x, UntagTag y, UntagTag xy, + SameLengths [x,y,xy], + HTypeIndexed x, HTypeIndexed y, + HUnzip TIP x y xy + -- HTypeIndexed xy is always satisfied given the above + -- constraints (with a handwaving proof), so don't require + -- callers of hZip/hUnzip to supply such proof + ) => HZip TIP x y xy where + hZip = hZipTIP + + +instance (HZipList (UntagR x) (UntagR y) (UntagR xy), + UntagTag x, UntagTag y, UntagTag xy, + HTypeIndexed x, HTypeIndexed y, + SameLengths [x,y,xy]) => HUnzip TIP x y xy where + hUnzip = hUnzipTIP + +#else +-- ghc-7.10.3 has coerce, but rejects these instances +instance (HZipList xL yL xyL, + lty ~ (HList xyL -> (HList xL,HList yL)), + Coercible lty (TIP xy -> (TIP x, TIP y)), + UntagR x ~ xL, TagR xL ~ x, -- `TagR (UntagR x) ~ x` included by UntagTag + UntagR y ~ yL, TagR yL ~ y, + UntagR xy ~ xyL, TagR xyL ~ xy, + SameLengths '[x,y,xy], + UntagTag x, UntagTag y, UntagTag xy + ) => HUnzip TIP x y xy where + hUnzip = coerce (hUnzipList :: lty) + +instance (HUnzip TIP x y xy, + HZipList xL yL xyL, + lty ~ (HList xL -> HList yL -> HList xyL), + Coercible lty (TIP x -> TIP y -> TIP xy) , + UntagR x ~ xL, + UntagR y ~ yL, + UntagR xy ~ xyL, + UntagTag x, UntagTag y, UntagTag xy + ) => HZip TIP x y xy where + hZip = coerce (hZipList :: lty) +#endif + +-- | specialization of 'hZip' +hZipTIP (TIP x) (TIP y) = TIP (hTagSelf (hZipList (hUntagSelf x) (hUntagSelf y))) + +-- | specialization of 'hUnzip' +hUnzipTIP (TIP xy) = case hUnzipList (hUntagSelf xy) of + (x,y) -> (mkTIP (hTagSelf x), mkTIP (hTagSelf y)) + + + +-- -------------------------------------------------------------------------- +-- * TIP Transform + +{- | + +Transforming a TIP: applying to a TIP a (polyvariadic) function +that takes arguments from a TIP and updates the TIP with the result. + +In more detail: we have a typed-indexed collection TIP and we +would like to apply a transformation function to it, whose argument +types and the result type are all in the TIP. The function should locate +its arguments based on their types, and update the TIP +with the result. The function may have any number of arguments, +including zero; the order of arguments should not matter. + +The problem was posed by Andrew U. Frank on Haskell-Cafe, Sep 10, 2009. + +The problem is an interesting variation of the keyword argument problem. + +Examples can be found in @examples/TIPTransform.hs@ and @examples/TIPTransformM.hs@ +-} + +class TransTIP op db where + ttip :: op -> TIP db -> TIP db + +instance (HMember (Tagged op op) db b, + Arity op n, + TransTIP1 b n op db) + => TransTIP op db where + ttip = ttip1 (Proxy ::Proxy b) (Proxy :: Proxy n) + +class TransTIP1 (b :: Bool) (n :: HNat) op db where + ttip1 :: Proxy b -> Proxy n -> op -> TIP db -> TIP db + +-- If op is found in a TIP, update the TIP with op +instance HTPupdateAtLabel TIP op op db + => TransTIP1 True n op db where + ttip1 _ _ = tipyUpdate + +-- If op is not found in a TIP, it must be a function. Try to look up +-- its argument in a TIP and recur. +instance (HMember (Tagged arg arg) db b, + TransTIP2 b arg op db) + => TransTIP1 False (HSucc n) (arg -> op) db where + ttip1 _ _ = ttip2 (Proxy :: Proxy b) + +instance Fail (FieldNotFound notfun (TIP db)) + => TransTIP1 False HZero notfun db where + ttip1 = error "TransTIP1 Fail failed" + +class TransTIP2 (b :: Bool) arg op db where + ttip2 :: Proxy b -> (arg -> op) -> TIP db -> TIP db + +instance (HOccurs arg (TIP db), + TransTIP op db) + => TransTIP2 True arg op db where + ttip2 _ f db = ttip (f (hOccurs db)) db + +instance Fail (FieldNotFound arg (TIP db)) + => TransTIP2 False arg op db where + ttip2 = error "TransTIP2 Fail failed" + +-- ** Monadic version + +{- | + +In March 2010, Andrew Frank extended the problem for monadic operations. +This is the monadic version of @TIPTransform.hs@ in the present directory. + +This is the TF implementation. When specifying the operation to perform over +a TIP, we can leave it polymorphic over the monad. The type checker +will instantiate the monad based on the context. + +-} +class Monad m => TransTIPM m op db where + ttipM :: op -> TIP db -> m (TIP db) + +-- Check to see if the operation is a computation whose result +-- is in the TIP. The type variable m' of the kind *->* below +-- can be instantiated either to a monad type constructor, or (arg->). +instance (Monad m, HMember (Tagged op op) db b, + Arity (m' op) n, + TransTIPM1 b n m (m' op) db) + => TransTIPM m (m' op) db where + ttipM = ttipM1 (Proxy :: Proxy b) (Proxy :: Proxy n) + +class Monad m => TransTIPM1 (b :: Bool) (n :: HNat) m op db where + ttipM1 :: Proxy b -> Proxy n -> op -> TIP db -> m (TIP db) + +-- If op is found in a TIP, update the TIP with op. +-- The type variable m' must be equal to the type of the monad +-- in which the final result is reported. +instance (Monad m, m ~ m', HTPupdateAtLabel TIP op op db) + => TransTIPM1 True n m (m' op) db where + ttipM1 _ _ op db = do + op' <- op + return $ tipyUpdate op' db + +instance (Fail (FieldNotFound op (TIP db)), Monad m) + => TransTIPM1 False HZero m op db where + ttipM1 _ _ = error "TransTIPM1 Fail failed" + +-- If op is not found in a TIP, it must be a function. Look up +-- its argument in a TIP and recur. +instance (Monad m, + HMember (Tagged arg arg) db b, + TransTIPM2 b m arg op db) + => TransTIPM1 False (HSucc n) m (arg-> op) db where + ttipM1 _ _ = ttipM2 (Proxy :: Proxy b) + + +class TransTIPM2 (b :: Bool) m arg op db where + ttipM2 :: Proxy b -> (arg -> op) -> TIP db -> m (TIP db) + +instance (HOccurs arg (TIP db), TransTIPM m op db) + => TransTIPM2 True m arg op db where + ttipM2 _ f db = ttipM (f (hOccurs db)) db + + +instance Fail (FieldNotFound op (TIP db)) + => TransTIPM2 False m arg op db where + ttipM2 _ _ = error "TransTIPM1 Fail failed" + +-- -------------------------------------------------------------------------- + +-- tests for tipyTuple. These only work if tipyTuple is compiled +-- in a module that has NoMonoLocalBinds enabled +_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Char, Bool) +_ = tipyTuple ( '1' .*. True .*. emptyTIP ) :: (Bool, Char) + + +-- -------------------------------------------------------------------------- + +-- * Sample code + +{- $setup + +[@Assume@] + +>>> import Data.HList.TypeEqO +>>> import Data.HList.FakePrelude +>>> import Data.HList.HOccurs + +>>> :{ +newtype Key = Key Integer deriving (Show,Eq,Ord) +newtype Name = Name String deriving (Show,Eq) +data Breed = Cow | Sheep deriving (Show,Eq) +newtype Price = Price Float deriving (Show,Eq,Ord) +data Disease = BSE | FM deriving (Show,Eq) +type Animal = TagR '[Key,Name,Breed,Price] +:} + +>>> :{ +let myTipyCow :: TIP Animal -- optional + myTipyCow = Key 42 .*. Name "Angus" .*. Cow .*. Price 75.5 .*. emptyTIP + animalKey :: (HOccurs Key l, SubType l (TIP Animal)) => l -> Key + animalKey = hOccurs +:} + +-} + +{- $sessionlog +[@Session log@] + +>>> :t myTipyCow +myTipyCow + :: TIP + '[Tagged Key Key, Tagged Name Name, Tagged Breed Breed, + Tagged Price Price] + +>>> hOccurs myTipyCow :: Breed +Cow + +>>> BSE .*. myTipyCow +TIPH[BSE,Key 42,Name "Angus",Cow,Price 75.5] + + + +>>> Sheep .*. hDeleteAtLabel (Label::Label Breed) myTipyCow +TIPH[Sheep,Key 42,Name "Angus",Price 75.5] + +>>> tipyUpdate Sheep myTipyCow +TIPH[Key 42,Name "Angus",Sheep,Price 75.5] + + +>>> tipyProject2 (Proxy :: Labels '[Name,Price]) myTipyCow +(TIPH[Name "Angus",Price 75.5],TIPH[Key 42,Cow]) + +>>> tipyProject (Proxy :: Labels '[Name,Price]) myTipyCow +TIPH[Name "Angus",Price 75.5] + +-} + + +{- $sessionlog2 + +Don't bother repeating the type error: + + +>>> Sheep .*. myTipyCow +... +...No instance for (Fail (DuplicatedLabel (Label Breed))) +... + +-} diff --git a/hlist/Data/HList/TIPtuple.hs b/hlist/Data/HList/TIPtuple.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/TIPtuple.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE NoTypeFamilies #-} +{- | Description: TIP functions needing different LANGUAGE extensions + +While NoMonoLocalBinds could be enabled in TIP.hs, the ghc manual warns +"type inference becomes less predicatable if you do so. (Read the papers!)". +These definitions don't need type families, putting these definitions in +a separate module avoids that mess. + +XXX these should be implemented in terms of 'HTuple' and 'tipyProject', +which means adding +-} +module Data.HList.TIPtuple where + +import Data.HList.HOccurs + +{- | project a TIP (or HList) into a tuple + +@tipyTuple' x = ('hOccurs' x, hOccurs x)@ + +behaves similarly, except @tipyTuple@ excludes +the possibility of looking up the same element +twice, which allows inferring a concrete type +in more situations. For example + +> (\x y z -> tipyTuple (x .*. y .*. emptyTIP) `asTypeOf` (x, z)) () 'x' + +has type @Char -> ((), Char)@. tipyTuple' would +need a type annotation to decide whether the type +should be @Char -> ((), Char)@ or @() -> ((), ())@ + +-} +tipyTuple l = t (,) `asTypeOf` t (flip (,)) + where + t f = case hOccursRest l of + (x, ly) -> case hOccursRest ly of + (y, _) -> f x y + +tipyTuple3 l = t (,,) + `asTypeOf` t (\a b c -> (b,c,a)) + `asTypeOf` t (\a b c -> (c,a,b)) + where + t f = case hOccursRest l of + (x, lyz) -> case hOccursRest lyz of + (y, lz) -> case hOccursRest lz of + (z, _) -> f x y z + +tipyTuple4 l = t (,,,) + `asTypeOf` t (\a b c d -> (b,c,d,a)) + `asTypeOf` t (\a b c d -> (c,d,a,b)) + `asTypeOf` t (\a b c d -> (d,a,b,c)) + where + t f = case hOccursRest l of + (a, lbcd) -> case hOccursRest lbcd of + (b, lcd) -> case hOccursRest lcd of + (c, ld) -> case hOccursRest ld of + (d, _) -> f a b c d + +tipyTuple5 l = t (,,,,) + `asTypeOf` t (\a b c d e -> (b,c,d,e,a)) + `asTypeOf` t (\a b c d e -> (c,d,e,a,b)) + `asTypeOf` t (\a b c d e -> (d,e,a,b,c)) + `asTypeOf` t (\a b c d e -> (e,a,b,c,d)) + where + t f = case hOccursRest l of + (a, lbcde) -> case hOccursRest lbcde of + (b, lcde) -> case hOccursRest lcde of + (c, lde) -> case hOccursRest lde of + (d, le) -> case hOccursRest le of + (e, _) -> f a b c d e diff --git a/hlist/Data/HList/TypeEqO.hs b/hlist/Data/HList/TypeEqO.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/TypeEqO.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +#if (__GLASGOW_HASKELL__ < 709) +{-# LANGUAGE OverlappingInstances #-} +{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} +#endif + +{- | + The HList library + + (C) 2004, Oleg Kiselyov, Ralf Laemmel, Keean Schupke + + Generic type equality predicate: + The implementation based on overlapping instances + The only place where overlapping instances are really used + besides Label5 + +-} + +module Data.HList.TypeEqO where + +import Data.HList.FakePrelude + +#if !NEW_TYPE_EQ +instance {-# OVERLAPPING #-} HEq x x True +instance {-# OVERLAPPABLE #-} False ~ b => HEq x y b +-- instance TypeEq x y HFalse -- would violate functional dependency +#endif + + + +class TupleType (t :: *) (b :: Bool) | t -> b +instance {-# OVERLAPPING #-} TupleType () True +instance {-# OVERLAPPING #-} TupleType (x,y) True +instance {-# OVERLAPPING #-} TupleType (x,y,z) True +-- Continue for a while +instance {-# OVERLAPPABLE #-} False ~ b => TupleType x b +-- instance TupleType x HFalse -- would violate functional dependency + +-- overlaps an instance Show (Proxy t) for convenience +instance {-# OVERLAPPING #-} Show (Proxy True) where show _ = "HTrue" +instance {-# OVERLAPPING #-} Show (Proxy False) where show _ = "HFalse" + +instance {-# OVERLAPPING #-} HNat2Integral n => Show (Proxy (n :: HNat)) where + show n = "H" ++ show (hNat2Integral n :: Integer) + + +instance {-# OVERLAPPABLE #-} hZero ~ HZero => ArityFwd f hZero +instance {-# OVERLAPPING #-} Arity f n => ArityFwd (x -> f) (HSucc n) + + +-- | All our keywords must be registered +class IsKeyFN (t :: *) (flag :: Bool) | t-> flag +-- | overlapping/fallback case +instance {-# OVERLAPPABLE #-} (False ~ flag) => IsKeyFN t flag + diff --git a/hlist/Data/HList/Variant.hs b/hlist/Data/HList/Variant.hs new file mode 100644 --- /dev/null +++ b/hlist/Data/HList/Variant.hs @@ -0,0 +1,1185 @@ +{-# LANGUAGE CPP #-} + +{- | + Description: Variants, i.e., labelled sums, generalizations of Either + + The HList library + + See + for the public (safe) interface. + + The implementation here follows "Data.Dynamic", though Typeable is not + needed. + + See @broken/VariantP.hs@ and @broken/VariantOld.hs@ for different approaches + to open sums. +-} + +module Data.HList.Variant where + +import Data.HList.FakePrelude +import Data.HList.Record +import Data.HList.HList +import Data.HList.HListPrelude +import Data.HList.HOccurs() +import Data.HList.HArray + +import Text.ParserCombinators.ReadP hiding (optional) + +import Unsafe.Coerce +import GHC.Exts (Constraint) +#if __GLASGOW_HASKELL__ <= 906 +import Data.Semigroup (Semigroup( .. )) +#endif +import Data.Data +import Control.Applicative +import LensDefs +import Control.Monad + +-- * Labels for doctests + +{- $setup + +>>> import Data.HList.RecordPuns +>>> let x = Label :: Label "x" +>>> let y = Label :: Label "y" +>>> let z = Label :: Label "z" +>>> let _left = Label :: Label "left" +>>> let _right = Label :: Label "right" + +>>> :set -XQuasiQuotes -XViewPatterns -XDataKinds + + +-- * Creating Variants + +It is necessary to specify the order in which the fields occur, using +a data type like + +>>> let p = Proxy :: Proxy '[Tagged "left" Char, Tagged "right" Int] + +Then this argument can be passed into 'mkVariant' + +>>> let v = mkVariant _left 'x' p +>>> let w = mkVariant _right 5 p + +>>> :t v +v :: Variant '[Tagged "left" Char, Tagged "right" Int] + +>>> :t w +w :: Variant '[Tagged "left" Char, Tagged "right" Int] + + +>>> [v,w] +[V{left='x'},V{right=5}] + +-} + + +-- ** Alternative: a 'Record' as the Proxy +{- $mkVariant2 + +The type of mkVariant also allows using a 'Record' as the proxy. For example: + +>>> :{ +let p2 = [pun| left right |] where + left = 'a' + right = (4::Int) +:} + +>>> let v2 = mkVariant _left 'x' p2 +>>> let w2 = mkVariant _right 5 p2 + +>>> :t v2 +v2 :: Variant '[Tagged "left" Char, Tagged "right" Int] + +>>> :t w2 +w2 :: Variant '[Tagged "left" Char, Tagged "right" Int] + +>>> (v2,w2) +(V{left='x'},V{right=5}) + +-} + +-- ** A polymorphic Proxy +{- $mkVariant3 + +It is also possible to leave the @Char@ and @Int@ as type variables, +and have them inferred. + +>>> let p3 = Proxy :: Proxy '[Tagged "left" a, Tagged "right" b] + +Using @p3@ takes some care. The following attempt shows the problem: + +>>> :{ +let v3' = mkVariant _left 'x' p3 + w3' = mkVariant _right (5::Int) p3 +:} + +>>> :t v3' +v3' :: Variant '[Tagged "left" Char, Tagged "right" b] + +>>> :t w3' +w3' :: Variant '[Tagged "left" a, Tagged "right" Int] + +Here each use of @p3@ does not constrain the type of the other use. +In some cases those type variables will be inferred from other constraints, +such as when putting the variants into a list + +>>> [v3', w3'] +[V{left='x'},V{right=5}] + +In other cases the other tags will be defaulted to (), at least if `ExtendedDefaultRules` is enabled: + +>>> v3' +V{left='x'} + +>>> :set -XNoExtendedDefaultRules +>>> v3' +... +...No instance for (Show ...) arising from a use of ‘print’ +... + + +Another way around this issue is to make sure that the proxy +is bound in a monomorphic pattern. These are patterns that allow +name shadowing. + +* @\p -> ...@ +* @case e of p -> ...@ +* @do p <- e; ...@ +* implicit parameters @let ?p = e in ...@ +* + +An example of the case: + +>>> :{ +let (v3,w3) = case p3 of + p -> (mkVariant _left 'x' p, + mkVariant _right (5 :: Int) p) +:} + + +>>> :t v3 +v3 :: Variant '[Tagged "left" Char, Tagged "right" Int] + +>>> :t w3 +w3 :: Variant '[Tagged "left" Char, Tagged "right" Int] + +-} + +-- -------------------------------------------------------------------------- +{- | +@Variant vs@ has an implementation similar to 'Dynamic', except the +contained value is one of the elements of the @vs@ list, rather than +being one particular instance of 'Typeable'. + +>>> v .!. _right +Nothing + +>>> v .!. _left +Just 'x' + +In some cases the 'pun' quasiquote works with variants, + +>>> let f [pun| left right |] = (left,right) +>>> f v +(Just 'x',Nothing) + +>>> f w +(Nothing,Just 5) + + +>>> let add1 v = hMapV (Fun succ :: Fun '[Enum] '()) v + +>>> f (add1 v) +(Just 'y',Nothing) + +>>> f (add1 w) +(Nothing,Just 6) + + +-} +data Variant (vs :: [*]) = Variant !Int Any + +#if __GLASGOW_HASKELL__ > 707 +-- the inferred role is phantom, which is not safe +type role Variant representational +#endif + + + +-- ** Unsafe operations + +-- | This is only safe if the n'th element of vs has type @Tagged t v@ +unsafeMkVariant :: Int -- ^ n + -> v + -> Variant vs +unsafeMkVariant n a = Variant n (unsafeCoerce a) + +{- | Safe when (e ~ e') given that + +> Tagged t e ~ HLookupByHNatR n v +> Tagged t' e' ~ HLookupByHNatR n v' + +'hUpdateAtLabel' is the safe version + +-} +unsafeCastVariant :: Variant v -> Variant v' +unsafeCastVariant (Variant n e) = Variant n e + +-- | in ghc>=7.8, 'Data.Coerce.coerce' is probably a better choice +castVariant :: (RecordValuesR v ~ RecordValuesR v', + SameLength v v') => Variant v -> Variant v' +castVariant = unsafeCastVariant + +instance Relabeled Variant where + relabeled = iso castVariant castVariant + +-- | private destructor. This is safe only if the value +-- contained actually has type `e` +unsafeUnVariant :: Variant v -> e +unsafeUnVariant (Variant _ e) = unsafeCoerce e + + +{- | This function is unsafe because it can lead to a runtime error +when used together with the 'HExtend' instance (.*.) + +>>> print $ (Label :: Label "x") .=. (Nothing :: Maybe ()) .*. unsafeEmptyVariant +V{*** Exception: invalid variant + +use 'mkVariant1' instead + +-} +unsafeEmptyVariant :: Variant '[] +unsafeEmptyVariant = unsafeMkVariant 0 () + +-- -------------------------------------------------------------------------- +-- * Public constructor + +class HasField x (Variant vs) (Maybe v) => + MkVariant x v vs | x vs -> v where + mkVariant :: Label x -- ^ the tag + -> v -- ^ value to be stored + -> proxy vs -- ^ a helper to fix the ordering and types of the + -- potential values that this variant contains. + -- Typically this will be a 'Proxy', 'Record' or + -- another 'Variant' + -> Variant vs + +mkVariant1 l v = l .=. Just v .*. unsafeEmptyVariant + +instance (HFindLabel x vs n, + HNat2Integral n, + HasField x (Variant vs) (Maybe v)) => + MkVariant x v vs where + mkVariant _x y _p = unsafeMkVariant (hNat2Integral (Proxy :: Proxy n)) y + -- done as a one-instance class instead of a function to be able to hide + -- the 'n' type variable + +-- -------------------------------------------------------------------------- +-- * Public destructor + +{- $note 'hLookupByLabel' (synonym '.!.') + +> (.!.) :: Variant v -> Label x -> Maybe e +> hLookupByLabel :: Label x -> Variant v -> Maybe e + +'hPrism' and 'hLens'' combine this with 'mkVariant' +-} +instance (HasField x (Record vs) a, + HFindLabel x vs n, + HNat2Integral n) + => HasField x (Variant vs) (Maybe a) where + hLookupByLabel _x (Variant n d) + | hNat2Integral (Proxy :: Proxy n) == n = Just (unsafeCoerce d) + | otherwise = Nothing + +splitVariant1 :: Variant (Tagged s x ': xs) -> Either x (Variant xs) +splitVariant1 (Variant 0 x) = Left (unsafeCoerce x) +splitVariant1 (Variant n x) = Right (Variant (n-1) x) + +-- | x ~ Tagged s t +splitVariant1' :: Variant (x ': xs) -> Either x (Variant xs) +splitVariant1' (Variant 0 x) = Left (unsafeCoerce x) +splitVariant1' (Variant n x) = Right (Variant (n-1) x) + +extendVariant :: Variant l -> Variant (e ': l) +extendVariant (Variant m e) = Variant (m+1) e + +-- -------------------------------------------------------------------------- +-- * Prism + +{- | Make a @Prism (Variant s) (Variant t) a b@ out of a Label. + +See "Data.HList.Labelable".'hLens'' is a more overloaded version. + +Few type annotations are necessary because of the restriction +that `s` and `t` have the same labels in the same order, and to +get \"t\" the \"a\" in \"s\" is replaced with \"b\". + +-} +class (SameLength s t, SameLabels s t) + => HPrism x s t a b + | x s -> a, x t -> b, -- lookup + x s b -> t, x t a -> s -- update + where + hPrism :: (Choice p, Applicative f) + => Label x -> p a (f b) -> p (Variant s) (f (Variant t)) + + +instance ( + MkVariant x b t, + + HasField x (Variant s) (Maybe a), + + -- labels in the HList are not changed at all: + -- number, ordering, actual values are all constant + SameLength s t, + SameLabels s t, + + -- only the target of the prism can have it's type changed + H2ProjectByLabels '[Label x] s si so, + H2ProjectByLabels '[Label x] t ti to, + so ~ to, + + -- to convince GHC the fundeps are satisfied + HUpdateAtLabel Variant x b s t, + HUpdateAtLabel Variant x a t s + ) => HPrism x s t a b where + hPrism x = prism (\b -> mkVariant x b Proxy) + (\s -> case hLookupByLabel x s of + Just a -> Right a + Nothing -> Left (unsafeCastVariant s :: Variant t)) + + + +-- -------------------------------------------------------------------------- +-- * Read +-- | Variants are not opaque +instance (ShowVariant vs) => Show (Variant vs) where + showsPrec _ v = ("V{"++) . showVariant v . ('}':) + + +-- | helper class for defining the Show instance +class ShowVariant vs where + showVariant :: Variant vs -> ShowS + +instance (ShowLabel l, Show v, ShowVariant (w ': ws)) + => ShowVariant (Tagged l v ': w ': ws) where + showVariant vs = case splitVariant1 vs of + Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest + Right wws -> showVariant wws + where l = Label :: Label l + +instance (ShowLabel l, Show v, lv ~ Tagged l v) => ShowVariant '[lv] where + showVariant vs = case splitVariant1 vs of + Left v -> \rest -> showLabel l ++ "=" ++ show v ++ rest + Right _ -> error "invalid variant" + where l = Label :: Label l + +-- -------------------------------------------------------------------------- +-- * Show +-- | A corresponding read instance + +instance ReadVariant v => Read (Variant v) where + readsPrec _ = readP_to_S $ do + _ <- string "V{" + r <- readVariant + _ <- string "}" + return r + +class ReadVariant vs where + readVariant :: ReadP (Variant vs) + +instance ReadVariant '[] where + readVariant = return unsafeEmptyVariant + +instance (ShowLabel l, Read v, ReadVariant vs, + HOccursNot (Label l) (LabelsOf vs)) + => ReadVariant (Tagged l v ': vs) where + readVariant = do + mlv <- optional lv + case mlv of + Nothing -> do + rest <- readVariant + return (l .=. mlv .*. rest) + Just e -> do + return (mkVariant l e p) + + where + lv = do + _ <- string (showLabel l) + _ <- string "=" + readS_to_P reads + + l = Label :: Label l + + p = Proxy :: Proxy (Tagged l v ': vs) + + +-- * Data +instance (Typeable (Variant v), GfoldlVariant v v, + GunfoldVariant v v, + VariantConstrs v) + => Data (Variant v) where + gfoldl = gfoldlVariant + gunfold k z c = gunfoldVariant (\con -> k (z con)) (Proxy :: Proxy v) (constrIndex c - 1) + toConstr v@(Variant n _) = case drop n (variantConstrs (dataTypeOf v) v) of + c : _ -> c + _ -> error "Data.HList.Variant.toConstr impossible" + dataTypeOf x = let self = mkDataType (show (typeOf x)) (variantConstrs self x) + in self + +class VariantConstrs (xs :: [*]) where + variantConstrs :: DataType -> proxy xs -> [Constr] + +instance VariantConstrs '[] where + variantConstrs _ _ = [] + +instance (ShowLabel l, VariantConstrs xs) => VariantConstrs (Tagged l e ': xs) where + variantConstrs dt _ = mkConstr dt (showLabel (Label :: Label l)) [] Prefix : + variantConstrs dt (Proxy :: Proxy xs) + + + + +{- | [@implementation of gunfold for Variant@] + +In ghci + +> :set -ddump-deriv -XDeriveDataTypeable +> data X a b c = A a | B b | C c deriving (Data,Typeable) + +shows that gunfold is defined something like + +> gunfold k z c = case constrIndex c of +> 1 -> k (z Ghci1.A) +> 2 -> k (z Ghci1.B) +> _ -> k (z Ghci1.C) + +If we instead had + +> type X a b c = Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c] + +Then we could write: + +> gunfold1 :: (forall b r. Data b => (b -> r) -> c r) +> -> Variant [Tagged "A" a, Tagged "B" b, Tagged "C" c] +> gunfold1 f c = case constrIndex c of +> 1 -> f mkA +> 2 -> f mkB +> _ -> f mkC +> where mkA a = mkVariant (Label :: Label "A") (a :: a) v +> mkB b = mkVariant (Label :: Label "B") (b :: b) v +> mkC c = mkVariant (Label :: Label "C") (c :: c) v +> v = Proxy :: Proxy [Tagged "A" a, Tagged "B" b, Tagged "C" c] + +where @f = k.z@ + + +-} +class GunfoldVariant (es :: [*]) v where + gunfoldVariant :: + (forall b. Data b => (b -> Variant v) -> c (Variant v)) + -- ^ @f = k . z@ + -> Proxy es + -> Int + -> c (Variant v) + +instance (MkVariant l e v, Data e) => GunfoldVariant '[Tagged l e] v where + gunfoldVariant f _ _ = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy) + +instance (MkVariant l e v, Data e, + GunfoldVariant (b ': bs) v) => GunfoldVariant (Tagged l e ': b ': bs) v where + gunfoldVariant f _ 0 = f (\e -> mkVariant (Label :: Label l) (e :: e) Proxy) + gunfoldVariant f _ n = gunfoldVariant f (Proxy :: Proxy (b ': bs)) (n-1) + + + +class GfoldlVariant xs xs' where + -- | the same as 'gfoldl', except the variant that is returned can have more + -- possible values (needed to actually implement gfoldl). + gfoldlVariant :: + (forall d b. Data d => c (d -> b) -> d -> c b) + -> (forall g. g -> c g) -> Variant xs -> c (Variant xs') + +instance (a ~ Tagged l v, MkVariant l v r, Data v, + GfoldlVariant (b ': c) r) + => GfoldlVariant (a ': b ': c) r where + gfoldlVariant k z xxs = case splitVariant1 xxs of + Right xs -> gfoldlVariant k z xs + -- If the c@type variable in 'gfoldl' had a Functor constraint, + -- this case could be extendVariant `fmap` gfoldl k z xs, + -- and then 'GfoldlVariant' would be unnecessary + Left x -> + let mkV e = mkVariant (Label :: Label l) e Proxy + in z mkV `k` x + +instance (Unvariant '[a] v, a ~ Tagged l v, Data v, + MkVariant l v b) => GfoldlVariant '[a] b where + gfoldlVariant k z xxs = z mkV `k` unvariant xxs + where mkV e = mkVariant (Label :: Label l) e Proxy + + + +-- -------------------------------------------------------------------------- +-- * Map +-- | Apply a function to all possible elements of the variant +newtype HMapV f = HMapV f + +-- | shortcut for @applyAB . HMapV@. 'hMap' is more general +hMapV f v = applyAB (HMapV f) v + +-- | @hMapOutV f = unvariant . hMapV f@, except an ambiguous type +-- variable is resolved by 'HMapOutV_gety' +hMapOutV :: forall x y z f. (SameLength x y, + HMapAux Variant (HFmap f) x y, + Unvariant y z, + HMapOutV_gety x z ~ y + ) => f -> Variant x -> z +hMapOutV f v = unvariant (hMapV f v :: Variant y) + + +-- | resolves an ambiguous type in 'hMapOutV' +type family HMapOutV_gety (x :: [*]) (z :: *) :: [*] +type instance HMapOutV_gety (Tagged s x ': xs) z = Tagged s z ': HMapOutV_gety xs z +type instance HMapOutV_gety '[] z = '[] + + +-- | apply a function to all values that could be in the variant. +instance (vx ~ Variant x, + vy ~ Variant y, + HMapAux Variant (HFmap f) x y, + SameLength x y) + => ApplyAB (HMapV f) vx vy where + applyAB (HMapV f) x = hMapAux (HFmap f) x + +instance (ApplyAB f te te') => HMapAux Variant f '[te] '[te'] where + hMapAux f v = case splitVariant1' v of + Left te -> unsafeMkVariant 0 (applyAB f te :: te') + Right _ -> error "HMapVAux: variant invariant broken" + +instance (ApplyAB f te te', + HMapCxt Variant f (l ': ls) (l' ': ls')) + => HMapAux Variant f (te ': l ': ls) (te' ': l' ': ls') where + hMapAux f v = case splitVariant1' v of + Left te -> unsafeMkVariant 0 (applyAB f te :: te') + Right es -> extendVariant (hMapAux f es) + +-- -------------------------------------------------------------------------- +-- * HUpdateAtLabel instance + +{- | + +> hUpdateAtLabel x e' (mkVariant x e proxy) == mkVariant x e' proxy +> hUpdateAtLabel y e' (mkVariant x e proxy) == mkVariant x e proxy + +-} +instance + (HUpdateVariantAtLabelCxt l e v v' n _e) => + HUpdateAtLabel Variant l e v v' where + hUpdateAtLabel l e v = case hLookupByLabel l v of + Just _e -> mkVariant l e (Proxy :: Proxy v') + Nothing -> unsafeCastVariant v + +type HUpdateVariantAtLabelCxt l e v v' n _e = + (HFindLabel l v n, + HFindLabel l v' n, + HUpdateAtHNatR n (Tagged l e) v ~ v', + HasField l (Variant v) (Maybe _e), + HasField l (Record v') e, + MkVariant l e v') + + +-- -------------------------------------------------------------------------- +-- * HExtend instance +{- | Extension for Variants prefers the first value + +> (l .=. Nothing) .*. v = v +> (l .=. Just e) .*. _ = mkVariant l e Proxy + +-} +instance (le ~ Tagged l (Maybe e), HOccursNot (Label l) (LabelsOf v)) => + HExtend le (Variant v) where + type HExtendR le (Variant v) = Variant (UnMaybe le ': v) + Tagged (Just e) .*. _ = unsafeMkVariant 0 e + Tagged Nothing .*. (Variant n e) = Variant (n+1) e + +type family UnMaybe le +type instance UnMaybe (Tagged l (Maybe e)) = Tagged l e + +-- | used for 'HExtend' 'TIP' +type instance UnMaybe (Maybe e) = e + + +-- -------------------------------------------------------------------------- +-- * Conversion to an untagged value +class HAllEqVal (x :: [*]) (b :: Bool) | x -> b +instance HAllEqVal '[] True +instance HAllEqVal '[x] True +instance (HEq a a' b, + HAllEqVal (Tagged t a' ': xs) b2, + HAnd b b2 ~ b3) => + HAllEqVal (Tagged s a ': Tagged t a' ': xs) b3 + + +class HAllEqVal' (x :: [*]) +instance HAllEqVal' '[] +instance HAllEqVal' '[x] +instance (HAllEqVal' (ta ': xs), + a' ~ a, + ta ~ Tagged t a, + ta' ~ Tagged t' a') + => HAllEqVal' (ta' ': ta ': xs) + + +{- | Similar to 'unvariant', except type variables in @v@ +will be made equal to @e@ if possible. That allows the type +of @Nothing@ to be inferred as @Maybe Char@. + +>>> unvariant' $ x .=. Nothing .*. mkVariant1 y 'y' +'y' + +However, this difference leads to more local error messages +(@Couldn't match type ‘()’ with ‘Char’@), rather than the following +with @unvariant@: + +> Fail +> '("Variant", +> '[Tagged "left" Char, Tagged "right" ()], +> "must have all values equal to ", +> e)) + +-} +class Unvariant' v e | v -> e where + unvariant' :: Variant v -> e + +instance (HAllEqVal' (Tagged () e ': v), Unvariant v e) => + Unvariant' v e where + unvariant' = unvariant + +{- | Convert a Variant which has all possibilities having the same type +into a value of that type. Analogous to @either id id@. + +See also 'unvariant'' -} +class Unvariant v e | v -> e where + unvariant :: Variant v -> e + +instance (Unvariant1 b v e, + HAllEqVal v b, + HAllEqVal (Tagged () e ': v) b) + => Unvariant v e where + unvariant = unvariant1 (Proxy :: Proxy b) + + +class Unvariant1 b v e | b v -> e where + unvariant1 :: Proxy b -> Variant v -> e + +instance (v ~ Tagged t1 e) + => Unvariant1 True (v ': vs) e where + unvariant1 _ = unsafeUnVariant + +data UnvariantTypeMismatch (vs :: [*]) + +instance Fail (UnvariantTypeMismatch (v ': vs)) + => Unvariant1 False (v ': vs) (UnvariantTypeMismatch (v ': vs)) where + unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances" + +instance Fail "Unvariant applied to empty variant" + => Unvariant1 b '[] (Proxy "Unvariant applied to empty variant") where + unvariant1 _ = error "Data.HList.Variant.Unvariant1 Fail must have no instances" + +{- | @Lens (Variant s) (Variant t) a b@ + +Analogue of @Control.Lens.chosen :: Lens (Either a a) (Either b b) a b@ +-} +unvarianted :: (Unvariant' s a, + Unvariant' t b, + SameLabels s t, -- extra constraints to reduce ambiguity + SameLength s t, + Functor f) => + (a -> f b) -> Variant s -> f (Variant t) +unvarianted f v@(Variant n _) = fmap (\e' -> unsafeMkVariant n e') + (f (unvariant' v)) + +-- | @Lens' (Variant s) a@ +-- +-- where we might have @s ~ '[Tagged t1 a, Tagged t2 a]@ +unvarianted' x = simple (unvarianted x) + +-- * Zip + +{- | Applies to variants that have the same labels +in the same order. A generalization of + +> zipEither :: Either a b -> Either a b -> Maybe (Either (a,a) (b,b)) +> zipEither (Left a) (Left a') = Just (Left (a,a')) +> zipEither (Right a) (Right a') = Just (Right (a,a')) +> zipEither _ _ = Nothing + +see 'HZip' for zipping other collections + +-} +class ZipVariant x y xy | x y -> xy, xy -> x y where + zipVariant :: Variant x -> Variant y -> Maybe (Variant xy) + +instance ZipVariant '[] '[] '[] where + zipVariant _ _ = Nothing + +instance (tx ~ Tagged t x, + ty ~ Tagged t y, + txy ~ Tagged t (x,y), + ZipVariant xs ys zs, + MkVariant t (x,y) (txy ': zs)) + => ZipVariant (tx ': xs) (ty ': ys) (txy ': zs) where + zipVariant x y = case (splitVariant1 x, splitVariant1 y) of + (Left x', Left y') -> Just (mkVariant (Label :: Label t) (x',y') Proxy) + (Right x', Right y') -> extendVariant <$> zipVariant x' y' + _ -> Nothing + + +instance (HUnzip Variant (x2 ': xs) (y2 ': ys) (xy2 ': xys), + SameLength xs ys, + SameLength ys xys, + tx ~ Tagged t x, + ty ~ Tagged t y, + txy ~ Tagged t (x,y)) + => HUnzip Variant (tx ': x2 ': xs) (ty ': y2 ': ys) (txy ': xy2 ': xys) where + hUnzip xy = case splitVariant1 xy of + Left (x,y) -> (mkVariant (Label :: Label t) x Proxy, + mkVariant (Label :: Label t) y Proxy) + Right xy' | (x,y) <- hUnzip xy' -> + (extendVariant x, + extendVariant y) + +instance (Unvariant '[txy] txy, + tx ~ Tagged t x, + ty ~ Tagged t y, + txy ~ Tagged t (x,y)) + => HUnzip Variant '[tx] '[ty] '[txy] where + hUnzip xy | Tagged (x,y) <- unvariant xy = + (mkVariant1 Label x, mkVariant1 Label y) + + +-- ** with a record + +{- | Apply a record of functions to a variant of values. +The functions are selected based on those having the same +label as the value. + +-} +class (SameLength v v', + SameLabels v v') => ZipVR fs v v' | fs v -> v' where + -- | 'zipVR' is probably a better choice in most + -- situations, since it requires that @fs@ has one function for every + -- element of @v@ + zipVR_ :: Record fs -> Variant v -> Variant v' + +instance (lv ~ Tagged l v, + lv' ~ Tagged l v', + HMemberM (Label l) (LabelsOf fs) b, + HasFieldM l (Record fs) f, + DemoteMaybe (v -> v) f ~ (v -> v'), + MkVariant l v' (lv' ': rs), + ZipVR fs vs rs) => + ZipVR fs (lv ': vs) (lv' ': rs) where + zipVR_ r lvs = case splitVariant1 lvs of + Left v | v' <- hLookupByLabelM l r (id :: v -> v) v -> mkVariant l v' Proxy + Right vs -> extendVariant $ zipVR_ r vs + where l = Label :: Label l + + +instance ZipVR fs '[] '[] where + zipVR_ _ x = x + +{- | + +>>> let xy = x .*. y .*. emptyProxy +>>> let p = Proxy `asLabelsOf` xy +>>> let vs = [ mkVariant x 1.0 p, mkVariant y () p ] + + +>>> zipVR (hBuild (+1) id) `map` vs +[V{x=2.0},V{y=()}] + + +-} +zipVR :: (SameLabels fs v, SameLength fs v, ZipVR fs v v', + ZipVRCxt fs v v') + => Record fs -> Variant v -> Variant v' +zipVR = zipVR_ + + +{- | Lets 'zipVR' act as if @'ZipVR' fs v v'@ had an FD @v v' -> fs@ + +> ZipVRCxt [Tagged s f, Tagged t g] +> [Tagged s fx, Tagged t gx] +> [Tagged s fy, Tagged t gy] +> = (f ~ (fx -> fy), g ~ (gx -> gy)) + +-} +type family ZipVRCxt (fs :: [*]) (xs :: [*]) (ys :: [*]) :: Constraint + +type instance ZipVRCxt (Tagged s f ': fs) (Tagged s x ': xs) (Tagged s y ': ys) = + (f ~ (x -> y), ZipVRCxt fs xs ys) +type instance ZipVRCxt '[] '[] '[] = () + +-- * Eq +instance Eq (Variant '[]) where + _ == _ = True + +instance (Eq (Variant xs), Eq x) => Eq (Variant (x ': xs)) where + v == v' = case (splitVariant1' v, splitVariant1' v') of + (Left l, Left r) -> l == r + (Right l, Right r) -> l == r + _ -> False + +-- ** Alternative Eq +-- | implemented like @and (zipWith (==) xs ys)@. Behaves the same as the Eq instances for 'Variant' +eqVariant v v' = maybe False (hMapOutV UncurryEq) $ zipVariant v v' + +data UncurryEq = UncurryEq + +instance (ee ~ (e,e), Eq e, bool ~ Bool) => + ApplyAB UncurryEq ee bool where + applyAB _ (e,e') = e == e' + +-- * Ord +instance Ord (Variant '[]) where + compare _ _ = EQ + +instance (Ord x, Ord (Variant xs)) => Ord (Variant (x ': xs)) where + compare a b = compare (splitVariant1' a) (splitVariant1' b) + +-- * Bounded +instance (Bounded x, Bounded z, + HRevAppR (Tagged s x ': xs) '[] ~ (Tagged t z ': sx), + MkVariant t z (Tagged s x ': xs)) + => Bounded (Variant (Tagged s x ': xs)) where + minBound = mkVariant (Label :: Label s) (minBound :: x) Proxy + maxBound = mkVariant (Label :: Label t) (maxBound :: z) Proxy + +-- * Enum +{- | + +>>> let t = minBound :: Variant '[Tagged "x" Bool, Tagged "y" Bool] +>>> [t .. maxBound] +[V{x=False},V{x=True},V{y=False},V{y=True}] + + +[@Odd behavior@] +There are some arguments that this instance should not exist. + +The last type in the Variant does not need to be Bounded. This +means that 'enumFrom' behaves a bit unexpectedly: + +>>> [False .. ] +[False,True] + +>>> [t .. ] +[V{x=False},V{x=True},V{y=False},V{y=True},V{y=*** Exception: Prelude.Enum.Bool.toEnum: bad argument + +This is a \"feature\" because it allows an @Enum (Variant '[Tagged \"a\" Bool, Tagged \"n\" 'Integer'])@ + +Another difficult choice is that the lower bound is @fromEnum 0@ rather than @minBound@: + +>>> take 5 [ minBound :: Variant '[Tagged "b" Bool, Tagged "i" Int] .. ] +[V{b=False},V{b=True},V{i=0},V{i=1},V{i=2}] + +-} +instance (Enum x, Bounded x, Enum (Variant (y ': z))) => Enum (Variant (Tagged s x ': y ': z)) where + fromEnum v = case splitVariant1 v of + Left x -> fromEnum x + Right yz -> 1 + fromEnum (maxBound :: Tagged s x) + fromEnum yz + + toEnum n + | m >= n = mkVariant (Label :: Label s) (toEnum n) Proxy + | otherwise = extendVariant $ toEnum (n - m - 1) + where m = fromEnum (maxBound :: Tagged s x) + +{- | + +While the instances could be written Enum (Variant '[]) +Eq/Ord which cannot produce values, so they have instances for +empty variants ('unsafeEmptyVariant'). Enum can produce values, +so it is better that @fromEnum 0 :: Variant '[]@ fails with No instance for +@Enum (Variant '[])@ than producing an invalid variant. + +-} +instance Enum x => Enum (Variant '[Tagged s x]) where + fromEnum v = case splitVariant1 v of + Left x -> fromEnum x + _ -> error "Data.HList.Variant fromEnum impossible" + toEnum n = mkVariant (Label :: Label s) (toEnum n) Proxy + +-- * Ix (TODO) + +-- * Semigroup +instance (Unvariant '[Tagged t x] x, Semigroup x) => Semigroup (Variant '[Tagged t x]) where + a <> b = case (unvariant a, unvariant b) of + (l, r) -> mkVariant (Label :: Label t) (l <> r) Proxy + +instance (Semigroup x, Semigroup (Variant (a ': b))) => Semigroup (Variant (Tagged t x ': a ': b)) where + a <> b = case (splitVariant1 a, splitVariant1 b) of + (Left l, Left r) -> mkVariant (Label :: Label t) (l <> r) Proxy + (Left l, _) -> mkVariant (Label :: Label t) l Proxy + (_, Left r) -> mkVariant (Label :: Label t) r Proxy + (Right l, Right r) -> extendVariant $ l <> r + +-- * Monoid +instance (Unvariant '[Tagged t x] x, Monoid x) => Monoid (Variant '[Tagged t x]) where + mempty = mkVariant (Label :: Label t) mempty Proxy +#if __GLASGOW_HASKELL__ <= 906 + mappend a b = case (unvariant a, unvariant b) of + (l, r) -> mkVariant (Label :: Label t) (mappend l r) Proxy +#endif + + +instance (Monoid x, Monoid (Variant (a ': b))) => Monoid (Variant (Tagged t x ': a ': b)) where + mempty = extendVariant mempty +#if __GLASGOW_HASKELL__ <= 906 + mappend a b = case (splitVariant1 a, splitVariant1 b) of + (Left l, Left r) -> mkVariant (Label :: Label t) (mappend l r) Proxy + (Left l, _) -> mkVariant (Label :: Label t) l Proxy + (_, Left r) -> mkVariant (Label :: Label t) r Proxy + (Right l, Right r) -> extendVariant $ mappend l r +#endif + +-- * Projection + +{- | convert a variant with more fields into one with fewer (or the same) +fields. + + +>>> let ty = Proxy :: Proxy [Tagged "left" Int, Tagged "right" Int] +>>> let l = mkVariant _left 1 ty +>>> let r = mkVariant _right 2 ty + + +>>> map projectVariant [l, r] :: [Maybe (Variant '[Tagged "left" Int])] +[Just V{left=1},Nothing] + + +@'rearrangeVariant' = 'fromJust' . 'projectVariant'@ is one implementation +of 'rearrangeVariant', since the result can have the same fields with +a different order: + +>>> let yt = Proxy :: Proxy [Tagged "right" Int, Tagged "left" Int] + +>>> map projectVariant [l, r] `asTypeOf` [Just (mkVariant _left 0 yt)] +[Just V{left=1},Just V{right=2}] + + +-} +class ProjectVariant x y where + projectVariant :: Variant x -> Maybe (Variant y) + +instance (ProjectVariant x ys, + HasField t (Variant x) (Maybe y), + HOccursNot (Label t) (LabelsOf ys), + ty ~ Tagged t y) + => ProjectVariant x (ty ': ys) where + projectVariant x = y `mplus` ys + where t = Label :: Label t + y = (\v -> mkVariant t v Proxy) <$> x .!. t + ys = (mty .*.) <$> (projectVariant x :: Maybe (Variant ys)) + mty = Tagged Nothing :: Tagged t (Maybe y) + +instance ProjectVariant x '[] where + projectVariant _ = Nothing + + + +{- | @projectExtendVariant = fmap 'extendVariant' . 'projectVariant'@ + +where intermediate variant is as large as possible. Used to implement +"Data.HList.Labelable".'projected' + +Note that: + +>>> let r = projectExtendVariant (mkVariant1 Label 1 :: Variant '[Tagged "x" Int]) +>>> r :: Maybe (Variant '[Tagged "x" Integer]) +Nothing + +-} +class HAllTaggedLV y => ProjectExtendVariant x y where + projectExtendVariant :: Variant x -> Maybe (Variant y) + +instance HAllTaggedLV y => ProjectExtendVariant '[] y where + projectExtendVariant _ = Nothing + +instance (lv ~ Tagged l v, + HMemberM lv y inY, + ProjectExtendVariant' inY lv y, + ProjectExtendVariant xs y + ) => ProjectExtendVariant (lv ': xs) y where + projectExtendVariant v = case splitVariant1' v of + Left lv -> projectExtendVariant' (Proxy :: Proxy inY) lv + Right v' -> projectExtendVariant v' + + +class ProjectExtendVariant' (inY :: Maybe [*]) lv (y :: [*]) where + projectExtendVariant' :: Proxy inY -> lv -> Maybe (Variant y) + +instance ProjectExtendVariant' Nothing lv y where + projectExtendVariant' _ _ = Nothing + +instance (MkVariant l v y, lv ~ Tagged l v) => ProjectExtendVariant' (Just t) lv y where + projectExtendVariant' _ (Tagged v) = Just (mkVariant (Label :: Label l) v Proxy) + + + +class (ProjectVariant x yin, + ProjectVariant x yout) => SplitVariant x yin yout where + splitVariant :: Variant x -> Either (Variant yin) (Variant yout) + +instance + (-- implementation + ProjectVariant x yin, + ProjectVariant x yout, + + -- constraints to ensure exactly one of + -- the uses of projectVariant gives a Just + H2ProjectByLabels (LabelsOf yin) x xi xo, + HRearrange (LabelsOf yin) xi yin, + HRearrange (LabelsOf yout) xo yout, + + HLeftUnion xi xo xixo, + HRearrange (LabelsOf x) xixo x, + + -- probably redundant + HAllTaggedLV x, HAllTaggedLV yin, HAllTaggedLV yout) => + SplitVariant x yin yout where + splitVariant x = case (projectVariant x, projectVariant x) of + (Nothing, Just yout) -> Right yout + (Just yin, Nothing) -> Left yin + _ -> error "Data.HList.Variant:splitVariant impossible" + +-- | @projectVariant . extendsVariant = Just@ (when the types match up) +-- +-- 'extendVariant' is a special case +class (HAllTaggedLV y, HAllTaggedLV x) => ExtendsVariant x y where + extendsVariant :: Variant x -> Variant y + +instance (MkVariant l e y, le ~ Tagged l e, + ExtendsVariant (b ': bs) y) => ExtendsVariant (le ': b ': bs) y where + extendsVariant v = case splitVariant1 v of + Left e -> mkVariant (Label :: Label l) (e :: e) Proxy + Right vs -> extendsVariant vs + +instance (HAllTaggedLV x, Unvariant '[le] e, MkVariant l e x, + le ~ Tagged l e) => ExtendsVariant '[le] x where + extendsVariant v = mkVariant (Label :: Label l) (unvariant v) Proxy + + +-- | @rearrangeVariant@ is a specialization of 'extendsVariant' whose +-- result is always . see also 'rearranged' +rearrangeVariant :: (SameLength v v', ExtendsVariant v v') + => Variant v -> Variant v' +rearrangeVariant v = extendsVariant v + +instance (SameLength s a, ExtendsVariant s a, + SameLength b t, ExtendsVariant b t) => Rearranged Variant s t a b + where + rearranged = iso rearrangeVariant rearrangeVariant + +-- | @Prism (Record tma) (Record tmb) (Variant ta) (Variant tb)@ +-- +-- see 'hMaybied'' +hMaybied x = prism variantToHMaybied + (\s -> case hMaybiedToVariants s of + [a] -> Right a + _ -> Left (hMapR HCastF s)) + x + + +data HCastF = HCastF + +instance (mx ~ Maybe x, + my ~ Maybe y, + HCast y x) => + ApplyAB HCastF mx my where + applyAB _ x = hCast =<< x + + + +{- | @Prism' (Record tma) (Variant ta)@ + +where @tma@ and @tmb@ are lists like + +> tma ~ '[Tagged x (Maybe a), Tagged y (Maybe b)] +> ta ~ '[Tagged x a , Tagged y b ] + +If one element of the record is Just, the Variant will +contain that element. Otherwise, the prism fails. + +[@Note@] + +The types work out to define a prism: + +@l = 'prism'' 'variantToHMaybied' ('listToMaybe' . 'hMaybiedToVariants')@ + +but the law: @s^?l ≡ Just a ==> l # a ≡ s@ is not followed, +because we could have: + +@ + s, s2 :: Record '[Tagged "x" (Maybe Int), Tagged "y" (Maybe Char)] + s = hBuild (Just 1) (Just '2') + s2 = hBuild (Just 1) Nothing + + v :: Variant '[Tagged "x" Int, Tagged "y" Char] + v = mkVariant (Label :: Label "x") 1 Proxy +@ + +So that @s^?l == Just v@. But @l#v == s2 /= s@, while the law +requires @l#v == s@. hMaybied avoids this problem by only +producing a value when there is only one present. + +-} +hMaybied' x = simple (hMaybied (simple x)) + +class VariantToHMaybied v r | v -> r, r -> v where + variantToHMaybied :: Variant v -> Record r + +instance VariantToHMaybied '[] '[] where + variantToHMaybied _ = emptyRecord + +instance (VariantToHMaybied v r, + HReplicateF nr ConstTaggedNothing () r, + + tx ~ Tagged t x, + tmx ~ Tagged t (Maybe x)) + => VariantToHMaybied (tx ': v) (tmx ': r) where + variantToHMaybied v = case splitVariant1 v of + Left x -> Record + $ HCons (Tagged (Just x)) + $ hReplicateF Proxy ConstTaggedNothing () + Right rest -> + case variantToHMaybied rest of + Record a -> Record $ (Tagged Nothing :: Tagged t (Maybe x)) `HCons` a + -- don't use (.*.) because we have (LabelsOf v ~ LabelsOf r), so + -- the duplicate check (HRLabelSet) implied by (.*.) is redundant + +data ConstTaggedNothing = ConstTaggedNothing +instance (y ~ Tagged t (Maybe e)) => ApplyAB ConstTaggedNothing x y where + applyAB _ _ = Tagged Nothing + +-- | Every element of the record that is Just becomes one element +-- in the resulting list. See 'hMaybied'' example types that @r@ +-- and @v@ can take. +hMaybiedToVariants :: + (HFoldr HMaybiedToVariantFs [Variant '[]] r [Variant v], -- impl + VariantToHMaybied v r -- evidence for typechecking + ) => Record r -> [Variant v] +hMaybiedToVariants (Record r) = hFoldr HMaybiedToVariantFs ([] :: [Variant '[]]) r + +data HMaybiedToVariantFs = HMaybiedToVariantFs + +instance (x ~ (Tagged t (Maybe e), [Variant v]), + y ~ [Variant (Tagged t e ': v)], + MkVariant t e (Tagged t e ': v)) + => ApplyAB HMaybiedToVariantFs x y where + + applyAB _ (Tagged me, v) = case me of + Just e -> mkVariant (Label :: Label t) e Proxy : map extendVariant v + _ -> fmap extendVariant v diff --git a/hlist/LensDefs.hs b/hlist/LensDefs.hs new file mode 100644 --- /dev/null +++ b/hlist/LensDefs.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE CPP #-} +-- | parts of lens that would be imported if we depended on it +module LensDefs + (module LensDefs, + module Control.Applicative, + Choice, + Profunctor, + Coercible) + where + +import Data.Profunctor +import Data.Profunctor.Unsafe +import Control.Applicative +import Control.Monad.Identity + +import Unsafe.Coerce +#if __GLASGOW_HASKELL__ > 707 +import GHC.Exts(Coercible) +#else +import GHC.Exts(Constraint) +-- | for ghc-7.6 we don't have coercible +type Coercible a b = (() :: Constraint) +#endif + + +type Equality' s a = forall p (f :: * -> *). a `p` f a -> s `p` f s + +{- | if we write @f' = simple . f@, then the inferred type is + +> f' :: (s ~ t, _) => Lens s t a b + +which normally will let ghc figure out (a~b). However with the +types that come up in HList this can only be figure out with +concrete types, so we use isSimple instead which also specifies +(a~b). + +-} +isSimple :: optic ~ (p a (f a) -> p s (f s)) => optic -> optic +isSimple = id +-- alternatively: isSimple x = simple . x . simple + +simple :: Equality' a a +simple = id + +-- Used by doctests (which should probably just import Control.Lens...) +infixl 1 & +x & f = f x + +infixr 4 %~ +l %~ f = \t -> runIdentity $ l (rmap Identity f) t + +iso :: (Profunctor p, Functor f) + => (s -> a) -> (b -> t) + -> p a (f b) -> p s (f t) +iso sa bt = dimap sa (fmap bt) + +-- | iso, except assumes that the functions supplied could +-- be 'Data.Coerce.coerce' +isoNewtype :: (Profunctor p, Functor f, + Coercible b t, -- Coercible (f b) (f t) -- is really needed but that complicates types later on (since f is forall'd) + Coercible a s) + => (s -> a) -> (b -> t) + -> p a (f b) -> p s (f t) +isoNewtype sa _bt x = coerceBT x .# sa + where coerceBT :: p a (f b) -> p a (f t) + coerceBT = unsafeCoerce + +prism :: (b -> t) -> (s -> Either t a) + -> (forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)) +prism bt seta = dimap seta (either pure (fmap bt)) . right' + +prism' :: (a -> s) -> (s -> Maybe a) + -> (forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)) +prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s)) diff --git a/multi-containers/Data/Multimap/Table.hs b/multi-containers/Data/Multimap/Table.hs new file mode 100644 --- /dev/null +++ b/multi-containers/Data/Multimap/Table.hs @@ -0,0 +1,126 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Multimap.Table +-- Maintainer : Ziyang Liu +-- +-- The @'Table' r c a@ type represents a finite two-dimensional table +-- that associates a pair of keys (a row key of type @r@ and +-- a column key of type @c@) with a value of type @a@. +-- +-- The implementation is backed by two maps: a @'Map' r ('Map' c) a@, and +-- a @'Map' c ('Map' r) a@, called "row map" and "column map", respectively. +-- +-- It is worth noting that all functions that traverse a table, such as +-- 'foldl', 'foldr', 'foldMap' and 'traverse', are row-oriented, i.e., +-- they traverse the table row by row. To traverse a table column +-- by column, 'transpose' the table first. +-- +-- In the following Big-O notations, unless otherwise noted, /n/ denotes +-- the size of the table (i.e., the total number of values for all +-- row and column keys), /r/ denotes the number of row keys that has at +-- least one value, /c/ denotes the number of column keys that has at +-- least one value, and /k = max r c/. +module Data.Multimap.Table ( + Table + + -- * Construction + , empty + , singleton + , fromRowMap + , fromColumnMap + , transpose + + -- ** From Unordered Lists + , fromList + + -- * Deletion\/Update + , insert + , delete + , deleteRow + , deleteColumn + , adjust + , adjustWithKeys + , update + , updateWithKeys + , alter + , alterWithKeys + + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , hasCell + , hasRow + , hasColumn + + -- ** Size + , null + , notNull + , size + + -- * Combine + -- ** Union + , union + , unionWith + , unionWithKeys + , unions + , unionsWith + , unionsWithKeys + + -- ** Difference + , difference + + -- * Traversal + -- ** Map + , map + , mapWithKeys + , traverseWithKeys + , traverseMaybeWithKeys + + -- ** Folds + , foldr + , foldl + , foldrWithKeys + , foldlWithKeys + , foldMapWithKeys + + -- ** Strict Folds + , foldr' + , foldl' + , foldrWithKeys' + , foldlWithKeys' + + -- * Conversion + , row + , column + , rowMap + , columnMap + , rowKeys + , columnKeys + , rowKeysSet + , columnKeysSet + + -- ** Lists + , toList + + -- ** Ordered lists + , toRowAscList + , toColumnAscList + , toRowDescList + , toColumnDescList + + -- * Filter + , filter + , filterRow + , filterColumn + , filterWithKeys + + , mapMaybe + , mapMaybeWithKeys + , mapEither + , mapEitherWithKeys + ) where + +import Data.Multimap.Table.Internal +import Prelude hiding (Foldable(..), filter, lookup, map) diff --git a/multi-containers/Data/Multimap/Table/Internal.hs b/multi-containers/Data/Multimap/Table/Internal.hs new file mode 100644 --- /dev/null +++ b/multi-containers/Data/Multimap/Table/Internal.hs @@ -0,0 +1,813 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Multimap.Table.Internal +-- Maintainer : Ziyang Liu +-- +module Data.Multimap.Table.Internal ( + Table (..) + , Size + + -- * Construction + , empty + , singleton + , fromRowMap + , fromColumnMap + , transpose + + -- ** From Unordered Lists + , fromList + + -- * Deletion\/Update + , insert + , delete + , deleteRow + , deleteColumn + , adjust + , adjustWithKeys + , update + , updateWithKeys + , alter + , alterWithKeys + + -- * Query + -- ** Lookup + , lookup + , (!?) + , (!) + , hasCell + , hasRow + , hasColumn + + -- ** Size + , null + , notNull + , size + + -- * Combine + -- ** Union + , union + , unionWith + , unionWithKeys + , unions + , unionsWith + , unionsWithKeys + + -- ** Difference + , difference + + -- * Traversal + -- ** Map + , map + , mapWithKeys + , traverseWithKeys + , traverseMaybeWithKeys + + -- ** Folds + , foldr + , foldl + , foldrWithKeys + , foldlWithKeys + , foldMapWithKeys + + -- ** Strict Folds + , foldr' + , foldl' + , foldrWithKeys' + , foldlWithKeys' + + -- * Conversion + , row + , column + , rowMap + , columnMap + , rowKeys + , columnKeys + , rowKeysSet + , columnKeysSet + + -- ** Lists + , toList + + -- ** Ordered lists + , toRowAscList + , toColumnAscList + , toRowDescList + , toColumnDescList + + -- * Filter + , filter + , filterRow + , filterColumn + , filterWithKeys + + , mapMaybe + , mapMaybeWithKeys + , mapEither + , mapEitherWithKeys + ) where + +import Control.Arrow ((&&&)) +import Data.Data (Data) +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import Data.Set (Set) + +import Prelude hiding (Foldable(..), filter, lookup, map) + +infixl 9 !,!? + +type Size = Int + +newtype Table r c a = Table (Map r (Map c a), Map c (Map r a), Size) + deriving (Eq, Ord, Data) + +instance (Show r, Show c, Show a) => Show (Table r c a) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + +instance (Ord r, Ord c, Read r, Read c, Read a) => Read (Table r c a) where + readsPrec p = readParen (p > 10) $ \ r -> do + ("fromList",s) <- lex r + (xs,t) <- reads s + pure (fromList xs,t) + +instance Functor (Table r c) where + fmap = map + +instance Foldable.Foldable (Table r c) where + foldMap = foldMapWithKeys . const . const + {-# INLINE foldMap #-} + +instance (Ord r, Ord c) => Traversable (Table r c) where + traverse = traverseWithKeys . const . const + {-# INLINE traverse #-} + +instance (Ord r, Ord c) => Semigroup (Table r c a) where + (<>) = union + +instance (Ord r, Ord c) => Monoid (Table r c a) where + mempty = empty + mappend = (<>) + +------------------------------------------------------------------------------ + +-- | /O(1)/. The empty table. +-- +-- > size empty === 0 +empty :: Table r c a +empty = Table (Map.empty, Map.empty, 0) + +-- | /O(1)/. A table with a single element. +-- +-- > singleton 1 'a' "a" === fromList [(1,'a',"a")] +-- > size (singleton 1 'a' "a") === 1 +singleton :: r -> c -> a -> Table r c a +singleton r c a = Table (Map.singleton r (Map.singleton c a), Map.singleton c (Map.singleton r a), 1) + +-- | Build a table from a list of key\/value pairs. +-- +-- > fromList ([] :: [(Int, Char, String)]) === empty +fromList :: (Ord r, Ord c) => [(r, c, a)] -> Table r c a +fromList = Foldable.foldr (uncurry3 insert) empty + +-- | Build a table from a row map. +-- +-- > fromRowMap (Map.fromList [(1, Map.fromList [('a',"b"),('b',"c")]), (2, Map.fromList [('a',"d")])]) +-- > === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")] +fromRowMap :: (Ord r, Ord c) => Map r (Map c a) -> Table r c a +fromRowMap m = Table (m', transpose' m', size' m') + where m' = nonEmpty m + +-- | Build a table from a column map. +-- +-- > fromColumnMap (Map.fromList [(1, Map.fromList [('a',"b"),('b',"c")]), (2, Map.fromList [('a',"d")])]) +-- > === fromList [('a',1,"b"),('a',2,"d"),('b',1,"c")] +fromColumnMap :: (Ord r, Ord c) => Map c (Map r a) -> Table r c a +fromColumnMap m = Table (transpose' m', m', size' m') + where m' = nonEmpty m + +-- | Flip the row and column keys. +-- +-- > transpose (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [('a',1,"b"),('a',2,"d"),('b',1,"c")] +transpose :: Table r c a -> Table c r a +transpose (Table (rm, cm, sz)) = Table (cm, rm, sz) + +------------------------------------------------------------------------------ + +-- | /O(log k)/. Associate with value with the row key and the column key. +-- If the table already contains a value for those keys, the value is replaced. +-- +-- > insert 1 'a' "a" empty === singleton 1 'a' "a" +-- > insert 1 'a' "a" (fromList [(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"d")] +-- > insert 1 'a' "a" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"d")] +insert :: (Ord r, Ord c) => r -> c -> a -> Table r c a -> Table r c a +insert r c a (Table (rm, cm, _)) = fromMaps' r c rm' cm' + where + rm' = Map.alter f r rm + cm' = Map.alter g c cm + f = Just . maybe (Map.singleton c a) (Map.insert c a) + g = Just . maybe (Map.singleton r a) (Map.insert r a) + +-- | /O(log k)/. Remove the value associated with the given keys. +-- +-- > delete 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'b',"c"),(2,'a',"d")] +-- > delete 1 'a' (fromList [(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'b',"c"),(2,'a',"d")] +delete :: (Ord r, Ord c) => r -> c -> Table r c a -> Table r c a +delete r c (Table (rm, cm, _)) = fromMaps' r c rm' cm' + where + rm' = Map.adjust (Map.delete c) r rm + cm' = Map.adjust (Map.delete r) c cm + +-- | Remove an entire row. +-- +-- > deleteRow 1 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 2 'a' "d" +-- > deleteRow 3 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")] +deleteRow :: Ord r => r -> Table r c a -> Table r c a +deleteRow r (Table (rm, cm, _)) = Table (rm', cm', size' rm') + where + rm' = Map.delete r rm + cm' = nonEmpty $ Map.map (Map.delete r) cm + +-- | Remove an entire column. +-- +-- > deleteColumn 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "c" +-- > deleteColumn 'z' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")] +deleteColumn :: Ord c => c -> Table r c a -> Table r c a +deleteColumn c (Table (rm, cm, _)) = Table (rm', cm', size' cm') + where + rm' = nonEmpty $ Map.map (Map.delete c) rm + cm' = Map.delete c cm + +-- | /O(log k)/, assuming the function @a -> a@ takes /O(1)/. +-- Update the value at a specific row key and column key, if exists. +-- +-- > adjust ("new " ++) 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === fromList [(1,'a',"new b"),(1,'b',"c"),(2,'a',"d")] +adjust :: (Ord r, Ord c) => (a -> a) -> r -> c -> Table r c a -> Table r c a +adjust = adjustWithKeys . const . const + +-- | /O(log k)/, assuming the function @r -> c -> a -> a@ takes /O(1)/. +-- Update the value at a specific row key and column key, if exists. +-- +-- > adjustWithKeys (\r c x -> show r ++ ":" ++ show c ++ ":new " ++ x) 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) +-- > === fromList [(1,'a',"1:'a':new b"),(1,'b',"c"),(2,'a',"d")] +adjustWithKeys + :: (Ord r, Ord c) + => (r -> c -> a -> a) -> r -> c -> Table r c a -> Table r c a +adjustWithKeys f = updateWithKeys (\r c a -> Just (f r c a)) + +-- | /O(log k)/, assuming the function @a -> 'Maybe' a@ takes /O(1)/. +-- The expression (@'update' f r c table@) updates the value at the given +-- row and column keys, if exists. If @f@ returns 'Nothing', the value +-- associated with those keys, if exists is deleted. +-- +-- > let f x = if x == "b" then Just "new b" else Nothing in do +-- > update f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"new b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > update f 1 'a' (fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +update :: (Ord r, Ord c) => (a -> Maybe a) -> r -> c -> Table r c a -> Table r c a +update = updateWithKeys . const . const + +-- | /O(log k)/, assuming the function @r -> c -> a -> 'Maybe' a@ takes /O(1)/. +-- The expression (@'updateWithKeys' f r c table@) updates the value at the given +-- row and column keys, if exists. If @f@ returns 'Nothing', the value +-- associated with those keys, if exists is deleted. +-- +-- > let f r c x = if x == "b" then Just (show r ++ ":" ++ show c ++ ":new b") else Nothing in do +-- > updateWithKeys f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"1:'a':new b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > updateWithKeys f 1 'a' (fromList [(1,'a',"a"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +updateWithKeys + :: (Ord r, Ord c) + => (r -> c -> a -> Maybe a) -> r -> c -> Table r c a -> Table r c a +updateWithKeys f = alterWithKeys (\r c -> (>>= f r c)) + +-- | /O(log k)/, assuming the function @'Maybe' a -> 'Maybe' a@ takes /O(1)/. +-- The expression (@'alter' f r c table@) alters the value at the given +-- row and column keys, if exists. It can be used to insert, delete +-- or update a value. +-- +-- > let (f,g,h) = (const Nothing, const (Just "hello"), fmap ('z':)) in do +-- > alter f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alter f 4 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alter f 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alter g 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"hello"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alter g 4 'e' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c"),(4,'e',"hello")] +-- > alter h 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"zb"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alter h 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +alter :: (Ord r, Ord c) => (Maybe a -> Maybe a) -> r -> c -> Table r c a -> Table r c a +alter = alterWithKeys . const . const + +-- | /O(log k)/, assuming the function @r -> c -> 'Maybe' a -> 'Maybe' a@ takes /O(1)/. +-- The expression (@'alterWithKeys' f r c table@) alters the value at the given +-- row and column keys, if exists. It can be used to insert, delete +-- or update a value. +-- +-- > let (f,g) = (\_ _ _ -> Nothing, \r c -> fmap ((show r ++ ":" ++ show c ++ ":") ++)) in do +-- > alterWithKeys f 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alterWithKeys f 4 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alterWithKeys f 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alterWithKeys g 1 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"1:'a':b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +-- > alterWithKeys g 2 'b' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")]) === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(3,'a',"c")] +alterWithKeys + :: (Ord r, Ord c) + => (r -> c -> Maybe a -> Maybe a) -> r -> c -> Table r c a -> Table r c a +alterWithKeys f r c tbl@(Table (rm, cm, _)) + | Just a <- f r c (lookup r c tbl) = + let rm' = Map.alter (Just . maybe (Map.singleton c a) (Map.insert c a)) r rm + cm' = Map.alter (Just . maybe (Map.singleton r a) (Map.insert r a)) c cm + in fromMaps' r c rm' cm' + | otherwise = delete r c tbl + +------------------------------------------------------------------------------ + +-- | /O(log k)/. Lookup the values at a row key and column key in the map. +lookup :: (Ord r, Ord c) => r -> c -> Table r c a -> Maybe a +lookup r c (Table (rm, _, _)) = Map.lookup r rm >>= Map.lookup c + +-- | /O(log k)/. Lookup the values at a row key and column key in the map. +-- +-- > fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")] !? (1,'a') === Just "b" +-- > fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")] !? (1,'c') === Nothing +(!?) :: (Ord r, Ord c) => Table r c a -> (r, c) -> Maybe a +(!?) = flip (uncurry lookup) + +-- | /O(log k)/. Lookup the values at a row key and column key in the map. +-- Calls 'error' if the value does not exist. +-- +-- > fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")] ! (1,'a') === "b" +(!) :: (Ord r, Ord c) => Table r c a -> (r, c) -> a +(!) tbl keys = + Maybe.fromMaybe (error "Table.!: cell does not exist") (tbl !? keys) + +-- | /O(log k)/. Is there a value associated with the given row and +-- column keys? +-- +-- > hasCell (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (1,'a') === True +-- > hasCell (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (1,'c') === False +hasCell :: (Ord r, Ord c) => Table r c a -> (r, c) -> Bool +hasCell (Table (rm, _, _)) (r, c) = + maybe False (Map.member c) (Map.lookup r rm) + +-- | /O(log r)/. Is there a row with the given row key that has at least +-- one value? +-- +-- > hasRow (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 1 === True +-- > hasRow (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 3 === False +hasRow :: Ord r => Table r c a -> r -> Bool +hasRow (Table (rm, _, _)) r = Map.member r rm + +-- | /O(log c)/. Is there a column with the given column key that has at least +-- one value? +-- +-- > hasColumn (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 'a' === True +-- > hasColumn (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) 'c' === False +hasColumn :: Ord c => Table r c a -> c -> Bool +hasColumn (Table (_, cm, _)) c = Map.member c cm + +-- | /O(1)/. Is the table empty? +-- +-- > Data.Multimap.Table.null empty === True +-- > Data.Multimap.Table.null (singleton 1 'a' "a") === False +null :: Table r c a -> Bool +null (Table (rm, _, _)) = Map.null rm + +-- | /O(1)/. Is the table non-empty? +-- +-- > notNull empty === False +-- > notNull (singleton 1 'a' "a") === True +notNull :: Table r c a -> Bool +notNull = not . null + +-- | The total number of values for all row and column keys. +-- +-- @size@ is evaluated lazily. Forcing the size for the first time takes up to +-- /O(n)/ and subsequent forces take /O(1)/. +-- +-- > size empty === 0 +-- > size (singleton 1 'a' "a") === 1 +-- > size (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) === 3 +size :: Table r c a -> Int +size (Table (_, _, sz)) = sz + +------------------------------------------------------------------------------ + +-- | Union two tables, preferring values from the first table +-- upon duplicate keys. +-- +-- > union (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]) +-- > === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")] +union :: (Ord r, Ord c) => Table r c a -> Table r c a -> Table r c a +union = unionWith const + +-- | Union a number of tables, preferring values from the leftmost table +-- upon duplicate keys. +-- +-- > unions [fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")], fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]] +-- > === fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")] +unions :: (Foldable f, Ord r, Ord c) => f (Table r c a) -> Table r c a +unions = Foldable.foldr union empty + +-- | Union two tables with a combining function for duplicate keys. +-- +-- > unionWith (++) (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]) +-- > === fromList [(1,'a',"bc"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")] +unionWith :: (Ord r, Ord c) => (a -> a -> a) -> Table r c a -> Table r c a -> Table r c a +unionWith = unionWithKeys . const . const + +-- | Union two tables with a combining function for duplicate keys. +-- +-- > let f r c a a' = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ a' in do +-- > unionWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]) +-- > === fromList [(1,'a',"1:'a':b|c"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")] +unionWithKeys + :: (Ord r, Ord c) + => (r -> c -> a -> a -> a) + -> Table r c a -> Table r c a -> Table r c a +unionWithKeys f (Table (rm1, cm1, _)) (Table (rm2, cm2, _)) = fromMaps rm cm + where + rm = Map.unionWithKey (Map.unionWithKey . f) rm1 rm2 + cm = Map.unionWithKey (Map.unionWithKey . flip f) cm1 cm2 + +-- | Union a number of tables with a combining function for duplicate keys. +-- +-- > unionsWith (++) [fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")], fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]] +-- > === fromList [(1,'a',"bc"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")] +unionsWith :: (Foldable f, Ord r, Ord c) => (a -> a -> a) -> f (Table r c a) -> Table r c a +unionsWith f = Foldable.foldr (unionWith f) empty + +-- | Union a number of tables with a combining function for duplicate keys. +-- +-- > let f r c a a' = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ a' in do +-- > unionsWithKeys f [fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")], fromList [(1,'a',"c"),(2,'b',"d"),(3,'c',"e")]] +-- > === fromList [(1,'a',"1:'a':b|c"),(1,'b',"c"),(2,'a',"b"),(2,'b',"d"),(3,'c',"e")] +unionsWithKeys + :: (Foldable f, Ord r, Ord c) + => (r -> c -> a -> a -> a) + -> f (Table r c a) -> Table r c a +unionsWithKeys f = Foldable.foldr (unionWithKeys f) empty + +-- | Difference of two tables. Return values in the first table whose +-- row and column keys do not have an associated value in the second table. +-- +-- > difference (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) (fromList [(1,'a',"c"),(1,'b',"d"),(2,'b',"b")]) +-- > === singleton 2 'a' "b" +difference :: (Ord r, Ord c) => Table r c a -> Table r c a -> Table r c a +difference (Table (rm1, cm1, _)) (Table (rm2, cm2, _)) = fromMaps rm cm + where + rm = Map.differenceWith ((Just .) . Map.difference) rm1 rm2 + cm = Map.differenceWith ((Just .) . Map.difference) cm1 cm2 + +------------------------------------------------------------------------------ + +-- | /O(n)/, assuming the function @a -> b@ takes /O(1)/. +-- Map a function over all values in the table. +-- +-- > Data.Multimap.Table.map (++ "x") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) === fromList [(1,'a',"bx"),(1,'b',"cx"),(2,'a',"bx")] +map :: (a -> b) -> Table r c a -> Table r c b +map = mapWithKeys . const . const + +-- | /O(n)/, assuming the function @r -> c -> a -> b@ takes /O(1)/. +-- Map a function over all values in the table. +-- +-- > mapWithKeys (\r c x -> show r ++ ":" ++ show c ++ ":" ++ x) (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) +-- > === fromList [(1,'a',"1:'a':b"),(1,'b',"1:'b':c"),(2,'a',"2:'a':b")] +mapWithKeys :: (r -> c -> a -> b) -> Table r c a -> Table r c b +mapWithKeys f (Table (rm, cm, sz)) = Table (rm', cm', sz) + where + rm' = Map.mapWithKey (Map.mapWithKey . f) rm + cm' = Map.mapWithKey (Map.mapWithKey . flip f) cm + +-- | Traverse the (row key, column key, value) triples and collect the results. +-- +-- > let f r c a = if odd r && c > 'a' then Just (a ++ "x") else Nothing in do +-- > traverseWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"b")]) === Nothing +-- > traverseWithKeys f (fromList [(1,'b',"b"),(1,'c',"c"),(3,'d',"b")]) === Just (fromList [(1,'b',"bx"),(1,'c',"cx"),(3,'d',"bx")]) +traverseWithKeys + :: (Applicative t, Ord r, Ord c) + => (r -> c -> a -> t b) + -> Table r c a + -> t (Table r c b) +traverseWithKeys f (Table (rm, _, _)) = fromMaps <$> rm' <*> cm' + where + rm' = Map.traverseWithKey (Map.traverseWithKey . f) rm + cm' = transpose' <$> rm' + +-- | Traverse the (row key, column key, value) triples and collect the 'Just' results. +traverseMaybeWithKeys + :: (Applicative t, Ord r, Ord c) + => (r -> c -> a -> t (Maybe b)) + -> Table r c a + -> t (Table r c b) +traverseMaybeWithKeys f (Table (rm, _, _)) = fromMaps <$> rm' <*> cm' + where + rm' = Map.traverseWithKey (Map.traverseMaybeWithKey . f) rm + cm' = transpose' <$> rm' + +------------------------------------------------------------------------------ + +-- | /O(n)/. Fold the values in the table row by row using the given +-- right-associative binary operator. +-- +-- > Data.Multimap.Table.foldr (:) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "bcd" +foldr :: (a -> b -> b) -> b -> Table r c a -> b +foldr = foldrWithKeys . const . const + +-- | /O(n)/. Fold the values in the table row by row using the given +-- left-associative binary operator. +-- +-- > Data.Multimap.Table.foldl (flip (:)) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "dcb" +foldl :: (a -> b -> a) -> a -> Table r c b -> a +foldl f = foldlWithKeys (\a _ _ -> f a) + +-- | /O(n)/. Fold the (row key, column key value) triplets in the table +-- row by row using the given right-associative binary operator. +-- +-- > let f r c a b = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ b in do +-- > foldrWithKeys f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "1:'a':b|1:'b':c|2:'a':d|" +foldrWithKeys :: (r -> c -> a -> b -> b) -> b -> Table r c a -> b +foldrWithKeys f b (Table (rm, _, _)) = Map.foldrWithKey f' b rm + where + f' = flip . Map.foldrWithKey . f + +-- | /O(n)/. Fold the (row key, column key, value) triplets in the table +-- row by row using the given left-associative binary operator. +-- +-- > let f a r c b = show r ++ ":" ++ show c ++ ":" ++ b ++ "|" ++ a in do +-- > foldlWithKeys f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "2:'a':d|1:'b':c|1:'a':b|" +foldlWithKeys :: (a -> r -> c -> b -> a) -> a -> Table r c b -> a +foldlWithKeys f a (Table (rm, _, _)) = Map.foldlWithKey f' a rm + where + f' = flip (Map.foldlWithKey . flip f) + +-- | /O(n)/. A strict version of 'foldr'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +-- +-- > Data.Multimap.Table.foldr' (:) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "bcd" +foldr' :: (a -> b -> b) -> b -> Table r c a -> b +foldr' = foldrWithKeys' . const . const + +-- | /O(n)/. A strict version of 'foldl'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +-- +-- > Data.Multimap.Table.foldl' (flip (:)) "" (fromList [(1,'a','b'),(1,'b','c'),(2,'a','d')]) === "dcb" +foldl' :: (a -> b -> a) -> a -> Table r c b -> a +foldl' f = foldlWithKeys' (\a _ _ -> f a) + +-- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +-- +-- > let f r c a b = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" ++ b in do +-- > foldrWithKeys' f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "1:'a':b|1:'b':c|2:'a':d|" +foldrWithKeys' :: (r -> c -> a -> b -> b) -> b -> Table r c a -> b +foldrWithKeys' f b (Table (rm, _, _)) = Map.foldrWithKey' f' b rm + where + f' = flip . Map.foldrWithKey' . f + +-- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the +-- operator is evaluated before using the result in the next application. +-- This function is strict in the starting value. +-- +-- > let f a r c b = show r ++ ":" ++ show c ++ ":" ++ b ++ "|" ++ a in do +-- > foldlWithKeys' f "" (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "2:'a':d|1:'b':c|1:'a':b|" +foldlWithKeys' :: (a -> r -> c -> b -> a) -> a -> Table r c b -> a +foldlWithKeys' f a (Table (rm, _, _)) = Map.foldlWithKey' f' a rm + where + f' = flip (Map.foldlWithKey' . flip f) + +-- | /O(n)/. Fold the (row key, column key, value) triplets in the map +-- row by row using the given monoid. +-- +-- > let f r c a = show r ++ ":" ++ show c ++ ":" ++ a ++ "|" in do +-- > foldMapWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === "1:'a':b|1:'b':c|2:'a':d|" +foldMapWithKeys :: Monoid m => (r -> c -> a -> m) -> Table r c a -> m +foldMapWithKeys f (Table (rm, _, _)) = Map.foldMapWithKey f' rm + where + f' = Map.foldMapWithKey . f + +------------------------------------------------------------------------------ + +-- | /O(r)/. Return a mapping from column keys to values for the given +-- row key. +-- +-- > row 1 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.fromList [('a',"b"),('b',"c")] +-- > row 3 (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.empty +row :: Ord r => r -> Table r c a -> Map c a +row r (Table (rm, _, _)) = Map.findWithDefault Map.empty r rm + +-- | /O(c)/. Return a mapping from row keys to values for the given +-- column key. +-- +-- > column 'a' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.fromList [(1,"b"),(2,"d")] +-- > column 'c' (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Map.empty +column :: Ord c => c -> Table r c a -> Map r a +column c (Table (_, cm, _)) = Map.findWithDefault Map.empty c cm + +-- | Return a mapping from row keys to maps from column keys to values. +-- +-- > rowMap (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) +-- > === Map.fromList [(1, Map.fromList [('a',"b"),('b',"c")]),(2, Map.fromList [('a',"d")])] +rowMap :: Table r c a -> Map r (Map c a) +rowMap (Table (rm, _, _)) = rm + +-- | Return a mapping from column keys to maps from row keys to values. +-- +-- > columnMap (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) +-- > === Map.fromList [('a', Map.fromList [(1,"b"),(2,"d")]),('b', Map.fromList [(1,"c")])] +columnMap :: Table r c a -> Map c (Map r a) +columnMap (Table (_, cm, _)) = cm + +-- | Return, in ascending order, the list of all row keys of that have +-- at least one value in the table. +-- +-- > rowKeys (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [1,2] +rowKeys :: Table r c a -> [r] +rowKeys (Table (rm, _, _)) = Map.keys rm + +-- | Return, in ascending order, the list of all column keys of that have +-- at least one value in the table. +-- +-- > columnKeys (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === ['a','b'] +columnKeys :: Table r c a -> [c] +columnKeys (Table (_, cm, _)) = Map.keys cm + +-- | Return the set of all row keys of that have at least one value +-- in the table. +-- +-- > rowKeysSet (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Set.fromList [1,2] +rowKeysSet :: Table r c a -> Set r +rowKeysSet (Table (rm, _, _)) = Map.keysSet rm + +-- | Return the set of all column keys of that have at least one value +-- in the table. +-- +-- > columnKeysSet (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === Set.fromList ['a','b'] +columnKeysSet :: Table r c a -> Set c +columnKeysSet (Table (_, cm, _)) = Map.keysSet cm + +-- | Convert the table into a list of (row key, column key, value) triples. +-- +-- > toList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")] +toList :: Table r c a -> [(r, c, a)] +toList (Table (rm, _, _)) = Map.toList (Map.toList <$> rm) >>= distr + +-- | Convert the table into a list of (row key, column key, value) triples +-- in ascending order of row keys, and ascending order of column keys +-- with a row. +-- +-- > toRowAscList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")] +toRowAscList :: Table r c a -> [(r, c, a)] +toRowAscList (Table (rm, _, _)) = Map.toAscList (Map.toAscList <$> rm) >>= distr + +-- | Convert the table into a list of (column key, row key, value) triples +-- in ascending order of column keys, and ascending order of row keys +-- with a column. +-- +-- > toColumnAscList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [('a',1,"b"),('a',2,"d"),('b',1,"c")] +toColumnAscList :: Table r c a -> [(c, r, a)] +toColumnAscList (Table (_, cm, _)) = Map.toAscList (Map.toAscList <$> cm) >>= distr + +-- | Convert the table into a list of (row key, column key, value) triples +-- in descending order of row keys, and descending order of column keys +-- with a row. +-- +-- > toRowDescList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [(2,'a',"d"),(1,'b',"c"),(1,'a',"b")] +toRowDescList :: Table r c a -> [(r, c, a)] +toRowDescList (Table (rm, _, _)) = Map.toDescList (Map.toDescList <$> rm) >>= distr + +-- | Convert the table into a list of (column key, row key, value) triples +-- in descending order of column keys, and descending order of row keys +-- with a column. +-- +-- > toColumnDescList (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === [('b',1,"c"),('a',2,"d"),('a',1,"b")] +toColumnDescList :: Table r c a -> [(c, r, a)] +toColumnDescList (Table (_, cm, _)) = Map.toDescList (Map.toDescList <$> cm) >>= distr + +------------------------------------------------------------------------------ + +-- | /O(n)/, assuming the predicate function takes /O(1)/. +-- Retain all values that satisfy the predicate. +-- +-- > Data.Multimap.Table.filter (> "c") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 2 'a' "d" +-- > Data.Multimap.Table.filter (> "d") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === empty +filter :: (a -> Bool) -> Table r c a -> Table r c a +filter = filterWithKeys . const . const + +-- | /O(r)/, assuming the predicate function takes /O(1)/. +-- Retain all rows that satisfy the predicate. +-- +-- > filterRow even (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 2 'a' "d" +filterRow :: (r -> Bool) -> Table r c a -> Table r c a +filterRow p (Table (rm, cm, _)) = Table (rm', nonEmpty cm', size' rm') + where + rm' = Map.filterWithKey (const . p) rm + cm' = Map.map (Map.filterWithKey (const . p)) cm + +-- | /O(c)/, assuming the predicate function takes /O(1)/. +-- Retain all columns that satisfy the predicate. +-- +-- > filterColumn (> 'a') (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "c" +filterColumn :: (c -> Bool) -> Table r c a -> Table r c a +filterColumn p (Table (rm, cm, _)) = Table (nonEmpty rm', cm', size' cm') + where + rm' = Map.map (Map.filterWithKey (const . p)) rm + cm' = Map.filterWithKey (const . p) cm + +-- | /O(c)/, assuming the predicate function takes /O(1)/. +-- Retain all (row key, column key, value) triples that satisfy the predicate. +-- +-- > filterWithKeys (\r c a -> odd r && c > 'a' && a > "b") (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "c" +filterWithKeys + :: (r -> c -> a -> Bool) + -> Table r c a + -> Table r c a +filterWithKeys p (Table (rm, cm, _)) = fromMaps rm' cm' + where + rm' = Map.mapWithKey (Map.filterWithKey . p) rm + cm' = Map.mapWithKey (Map.filterWithKey . flip p) cm + +-- | /O(n)/, assuming the function @a -> 'Maybe' b@ takes /O(1)/. +-- Map values and collect the 'Just' results. +-- +-- > mapMaybe (\a -> if a == "a" then Just "new a" else Nothing) (fromList [(1,'a',"a"),(1,'b',"c"),(2,'b',"a")]) +-- > === fromList [(1,'a',"new a"),(2,'b',"new a")] +mapMaybe :: (a -> Maybe b) -> Table r c a -> Table r c b +mapMaybe = mapMaybeWithKeys . const . const + +-- | /O(n)/, assuming the function @r -> c -> a -> 'Maybe' b@ takes /O(1)/. +-- Map (row key, column key, value) triples and collect the 'Just' results. +-- +-- > let f r c a = if r == 1 && a == "c" then Just "new c" else Nothing in do +-- > mapMaybeWithKeys f (fromList [(1,'a',"b"),(1,'b',"c"),(2,'a',"d")]) === singleton 1 'b' "new c" +mapMaybeWithKeys :: (r -> c -> a -> Maybe b) -> Table r c a -> Table r c b +mapMaybeWithKeys f (Table (rm, cm, _)) = fromMaps rm' cm' + where + rm' = Map.mapWithKey (Map.mapMaybeWithKey . f) rm + cm' = Map.mapWithKey (Map.mapMaybeWithKey . flip f) cm + +-- | /O(n)/, assuming the function @a -> 'Either' a1 a2@ takes /O(1)/. +-- Map values and separate the 'Left' and 'Right' results. +-- +-- > mapEither (\a -> if a == "a" then Left a else Right a) (fromList [(1,'a',"a"),(1,'b',"c"),(2,'b',"a")]) +-- > === (fromList [(1,'a',"a"),(2,'b',"a")],fromList [(1,'b',"c")]) +mapEither :: (a -> Either a1 a2) -> Table r c a -> (Table r c a1, Table r c a2) +mapEither = mapEitherWithKeys . const . const + +-- | /O(n)/, assuming the function @r -> c -> a -> 'Either' a1 a2@ takes /O(1)/. +-- Map (row key, column key, value) triples and separate the 'Left' and 'Right' results. +-- +-- > mapEitherWithKeys (\r c a -> if r == 1 && c == 'a' then Left a else Right a) (fromList [(1,'a',"a"),(1,'b',"c"),(2,'b',"a")]) +-- > === (fromList [(1,'a',"a")],fromList [(1,'b',"c"),(2,'b',"a")]) +mapEitherWithKeys :: (r -> c -> a -> Either a1 a2) -> Table r c a -> (Table r c a1, Table r c a2) +mapEitherWithKeys f (Table (rm, cm, _)) = (fromMaps rm1 cm1, fromMaps rm2 cm2) + where + (rm1, rm2) = (fmap fst &&& fmap snd) $ Map.mapWithKey (Map.mapEitherWithKey . f) rm + (cm1, cm2) = (fmap fst &&& fmap snd) $ Map.mapWithKey (Map.mapEitherWithKey . flip f) cm + +------------------------------------------------------------------------------ +-- * Non exported functions +------------------------------------------------------------------------------ + +assoc :: (a, (b, c)) -> (a, b, c) +assoc (a, (b, c)) = (a, b, c) + +distr :: (a, [(b, c)]) -> [(a, b, c)] +distr = fmap assoc . uncurry (zip . repeat) + +-- | Build a table from a row map and a column map. +fromMaps :: Map r (Map c a) -> Map c (Map r a) -> Table r c a +fromMaps rm cm = Table (rm', cm', size' rm') + where + rm' = nonEmpty rm + cm' = nonEmpty cm + +fromMaps' :: (Ord r, Ord c) => r -> c -> Map r (Map c a) -> Map c (Map r a) -> Table r c a +fromMaps' r c rm cm = Table (rm', cm', size' rm') + where + rm' = nonEmpty' r rm + cm' = nonEmpty' c cm + +nonEmpty :: Map k1 (Map k2 a) -> Map k1 (Map k2 a) +nonEmpty = Map.filter (not . Map.null) + +nonEmpty' :: Ord k1 => k1 -> Map k1 (Map k2 a) -> Map k1 (Map k2 a) +nonEmpty' k1 m = case Map.lookup k1 m of + Just m' | Map.null m' -> Map.delete k1 m + _ -> m + +transpose' :: (Ord r, Ord c) => Map r (Map c a) -> Map c (Map r a) +transpose' = Map.foldrWithKey' f Map.empty + where + f r = Map.unionWith Map.union . Map.map (Map.singleton r) + +size' :: Map k1 (Map k2 a) -> Int +size' = Foldable.sum . fmap Map.size + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f ~(a, b, c) = f a b c diff --git a/quick-process.cabal b/quick-process.cabal --- a/quick-process.cabal +++ b/quick-process.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: quick-process -version: 0.0.1 +version: 0.0.3 synopsis: Run external processes verified at compilation/installation description: The library checks program name during compilation, generates exec spec @@ -205,7 +205,7 @@ > [ Subcase "FindPrintf" > (KeyArg @(Refined (Regex "^[%][fpactbnM%]$") String) "-printf" .*. HNil) > , Subcase "FindExec" - > (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArg "{}" .*. ConstArg ";" .*. HNil) + > (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArgs (words "{} ;") .*. HNil) > ] > .*. HNil > ) @@ -214,6 +214,36 @@ Note usage of @Regex@ predicate - thanks to and z3 SMT solver values satisfing arbitrary TDFA regex can be generated. + + === Init Cascade + #init-cascade# + + A call spec may require another command to be executed somewhere in the + past e.g. most of git commands work only with initialize repository. + + > {-# LANGUAGE TemplateHaskell #-} + > module CallSpecs where + > + > import CallSpecs.GitInit qualified as I + > import System.Process.Quick + > + > $(genCallSpec + > [SandboxValidate] + > "git" + > ( ConstArg "remote" + > .*. StdErrMatches "^$" + > .*. StdOutMatches "^$" + > .*. Init @I.Git + > .*. HNil + > ) + > ) + + == Generated TH code inspection + #generated-th-code-inspection# + + GHC prints generated TH code with pragma: + + > {-# OPTIONS_GHC -ddump-splices #-} homepage: http://github.com/yaitskov/quick-process license: BSD-3-Clause @@ -226,7 +256,7 @@ extra-doc-files: changelog.md tested-with: - GHC == 9.10.1 + GHC == 9.10.1, GHC == 9.12.2 source-repository head type: @@ -244,17 +274,98 @@ default-extensions: DefaultSignatures NoImplicitPrelude + OverloadedLabels OverloadedStrings TemplateHaskell build-depends: - HList >= 0.5.4.0 && < 1 - , QuickCheck >= 2.14.3 && < 3 - , base >=4 && < 5 + QuickCheck >= 2.14.3 && < 3 + , base >=4.7 && < 5 , bytestring >= 0.12.1 && < 1 , generic-lens >= 2.2.2 && < 3 , lens >= 5.3.2 && < 6 , relude >= 1.2.2 && < 2 +library hlist-internal + hs-source-dirs: hlist + Build-Depends: base >= 4.7 && < 5, + -- for Typeable '[] and '(:) with ghc-7.6 + base-orphans < 1, + template-haskell < 3, + ghc-prim < 0.16, + mtl >= 2.3.1 && < 3, + tagged < 1, + profunctors >= 5.6.2 && < 6, + array < 1 + Exposed-modules: Data.HList, + Data.HList.CommonMain, + Data.HList.Data, + Data.HList.Dredge, + Data.HList.FakePrelude, + Data.HList.HArray, + Data.HList.HCurry, + Data.HList.HList, + Data.HList.HListPrelude, + Data.HList.HOccurs, + Data.HList.HTypeIndexed, + Data.HList.HSort, + Data.HList.HZip, + Data.HList.Keyword, + Data.HList.Label3, + Data.HList.Label5, + Data.HList.Label6, + Data.HList.Labelable, + Data.HList.MakeLabels, + Data.HList.Record, + Data.HList.RecordPuns, + Data.HList.RecordU, + Data.HList.TIC, + Data.HList.TIP, + Data.HList.TIPtuple, + Data.HList.TypeEqO, + Data.HList.Variant + Other-modules: LensDefs + Default-Language: Haskell2010 + Ghc-Options: -Wall -fno-warn-missing-signatures + -fno-warn-orphans + -fno-warn-unticked-promoted-constructors + -Wno-star-is-type + Default-Extensions: ConstraintKinds + DataKinds + DeriveDataTypeable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GeneralizedNewtypeDeriving + GADTs + KindSignatures + MultiParamTypeClasses + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeFamilies + TypeOperators + UndecidableInstances + StarIsType + UndecidableSuperClasses + AllowAmbiguousTypes + RoleAnnotations + Other-Extensions: CPP + TemplateHaskell + OverlappingInstances + +library multi-containers-internal + hs-source-dirs: multi-containers + exposed-modules: + Data.Multimap.Table + Data.Multimap.Table.Internal + build-depends: + base >=4.7 && <5 + , containers >=0.5.10.2 && <0.8 + default-language: Haskell2010 + ghc-options: -Wall + -- https://github.com/erikd/conduit-find/pull/17 library conduit-find-internal import: base @@ -318,10 +429,15 @@ System.Process.Quick.CallEffect System.Process.Quick.CallArgument System.Process.Quick.CallSpec + System.Process.Quick.CallSpec.Init System.Process.Quick.CallSpec.Run System.Process.Quick.CallSpec.Subcases System.Process.Quick.CallSpec.Type System.Process.Quick.CallSpec.Verify + System.Process.Quick.CallSpec.Verify.ImportOverlook + System.Process.Quick.CallSpec.Verify.Sandbox + System.Process.Quick.CallSpec.Verify.TrailingHelp + System.Process.Quick.CallSpec.Verify.Type System.Process.Quick.OrphanArbitrary System.Process.Quick.Predicate System.Process.Quick.Predicate.ImplDir @@ -333,6 +449,7 @@ System.Process.Quick.Pretty System.Process.Quick.Sbv.Arbitrary System.Process.Quick.TdfaToSbvRegex + System.Process.Quick.Util build-depends: casing < 1 , conduit < 2 @@ -340,9 +457,14 @@ , containers < 1 , directory < 2 , filepath < 2 + , generic-data < 2 + , generic-deriving < 2 , generic-random < 2 + , hlist-internal + , monad-time < 1 , mtl < 3 - , pretty < 2 + , multi-containers-internal + , pretty-simple < 5 , process < 2 , refined-internal , regex-compat < 1 @@ -352,8 +474,10 @@ , template-haskell < 3 , temporary < 2 , th-utilities < 1 - , trace-embrace < 2 + , time < 2 + , trace-embrace >= 1.2.0 && < 2 , unix < 3 + , wl-pprint-text < 2 test-suite verify-call-specs import: base @@ -365,7 +489,9 @@ hs-source-dirs: verify-call-specs ghc-options: -Wall -rtsopts -threaded -main-is VerifyCallSpecs - build-depends: quick-process + build-depends: + quick-process + , hlist-internal test-suite sandbox-effect import: base @@ -376,11 +502,16 @@ CallSpecs.CpManyToDir CallSpecs.Date CallSpecs.FindCases + CallSpecs.GitInit + CallSpecs.GitInitExit1 + CallSpecs.GitRemote + CallSpecs.GitSubcases hs-source-dirs: sandbox-effect ghc-options: -Wall -rtsopts -threaded -main-is SandBoxEffect build-depends: quick-process + , hlist-internal , refined-internal test-suite test @@ -403,6 +534,7 @@ ghc-options: -Wall -rtsopts -threaded -main-is Driver build-depends: directory + , hlist-internal , quickcheck-instances , refined-internal , th-utilities diff --git a/sandbox-effect/CallSpecs/FindCases.hs b/sandbox-effect/CallSpecs/FindCases.hs --- a/sandbox-effect/CallSpecs/FindCases.hs +++ b/sandbox-effect/CallSpecs/FindCases.hs @@ -15,7 +15,7 @@ [ Subcase "FindPrintf" (KeyArg @(Refined (Regex "^[%][fpactbnM%]$") String) "-printf" .*. HNil) , Subcase "FindExec" - (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArg "{}" .*. ConstArg ";" .*. HNil) + (KeyArg @(Refined (Regex "^(ls|file|du)$") String) "-exec" .*. ConstArgs ["{}", ";"] .*. HNil) ] .*. HNil ) diff --git a/sandbox-effect/CallSpecs/GitInit.hs b/sandbox-effect/CallSpecs/GitInit.hs new file mode 100644 --- /dev/null +++ b/sandbox-effect/CallSpecs/GitInit.hs @@ -0,0 +1,18 @@ +-- {-# OPTIONS_GHC -ddump-splices #-} +module CallSpecs.GitInit where + +import Data.String qualified as S +import System.Process.Quick +import System.Process.Quick.Prelude + +$(genCallSpec + [TrailingHelpValidate, SandboxValidate] + "git" + ( ConstArgs (S.words "-c init.defaultBranch=master init") + .*. ExitCodeEqualTo ExitSuccess + .*. StdErrMatches "^$" + .*. StdOutMatches "^Initialized empty Git repository" + .*. DirCreated ".git" + .*. HNil + ) + ) diff --git a/sandbox-effect/CallSpecs/GitInitExit1.hs b/sandbox-effect/CallSpecs/GitInitExit1.hs new file mode 100644 --- /dev/null +++ b/sandbox-effect/CallSpecs/GitInitExit1.hs @@ -0,0 +1,17 @@ +-- {-# OPTIONS_GHC -ddump-splices #-} +module CallSpecs.GitInitExit1 where + +import System.Process.Quick +import System.Process.Quick.Prelude + +$(genCallSpec + [TrailingHelpValidate, SandboxValidate] + "git" + ( ConstArg "initt" + .*. ExitCodeEqualTo (ExitFailure 1) + .*. StdErrMatches "is not a git command" + .*. StdOutMatches "^$" + -- .*. DirCreated ".git" + .*. HNil + ) + ) diff --git a/sandbox-effect/CallSpecs/GitRemote.hs b/sandbox-effect/CallSpecs/GitRemote.hs new file mode 100644 --- /dev/null +++ b/sandbox-effect/CallSpecs/GitRemote.hs @@ -0,0 +1,16 @@ +-- {-# OPTIONS_GHC -ddump-splices #-} +module CallSpecs.GitRemote where + +import CallSpecs.GitInit qualified as I +import System.Process.Quick + +$(genCallSpec + [SandboxValidate] + "git" + ( ConstArg "remote" + .*. StdErrMatches "^$" + .*. StdOutMatches "^$" + .*. Init @I.Git + .*. HNil + ) + ) diff --git a/sandbox-effect/CallSpecs/GitSubcases.hs b/sandbox-effect/CallSpecs/GitSubcases.hs new file mode 100644 --- /dev/null +++ b/sandbox-effect/CallSpecs/GitSubcases.hs @@ -0,0 +1,31 @@ +-- {-# OPTIONS_GHC -ddump-splices #-} +module CallSpecs.GitSubcases where + +import CallSpecs.GitInit qualified as I +import Data.String qualified as S +import System.Process.Quick +import System.Process.Quick.Prelude + +$(genCallSpec + [TrailingHelpValidate, SandboxValidate] + "git" + ( ConstArgs (S.words "--no-pager --no-replace-objects") + .*. Subcases "GitSubCases" + [ Subcase "Success" + ( ConstArg "reset" + .*. StdErrMatches "^$" + .*. StdOutMatches "^$" + .*. Init @I.Git + .*. HNil + ) + , Subcase "Fail" + ( ConstArg "initt" + .*. ExitCodeEqualTo (ExitFailure 1) + .*. StdErrMatches "is not a git command" + .*. StdOutMatches "^$" + .*. HNil + ) + ] + .*. HNil + ) + ) diff --git a/sandbox-effect/SandBoxEffect.hs b/sandbox-effect/SandBoxEffect.hs --- a/sandbox-effect/SandBoxEffect.hs +++ b/sandbox-effect/SandBoxEffect.hs @@ -5,10 +5,18 @@ import CallSpecs.CpManyToDir () import CallSpecs.Date import CallSpecs.FindCases () +import CallSpecs.GitInit () +import CallSpecs.GitInitExit1 () +import CallSpecs.GitRemote () +import CallSpecs.GitSubcases () import System.Process.Quick import System.Process.Quick.Prelude main :: IO () main = do - $(discoverAndVerifyCallSpecs (fromList [SandboxValidate]) 1) + startedAt <- currentTime + $(discoverAndVerifyCallSpecs (fromList [SandboxValidate]) 3) + endedAt <- currentTime + putStrLn $ "Execution of expr generated by discoverAndVerifyCallSpecs took " <> + show (endedAt `diffUTCTime` startedAt) callProcess $ Date $$(refineTH "+%Y") diff --git a/src/System/Process/Quick.hs b/src/System/Process/Quick.hs --- a/src/System/Process/Quick.hs +++ b/src/System/Process/Quick.hs @@ -3,7 +3,9 @@ import Data.HList as M (HList(..), (.*.)) import Refined as M import System.Process.Quick.CallArgument as M +import System.Process.Quick.CallEffect as M import System.Process.Quick.CallSpec as M +import System.Process.Quick.CallSpec.Init as M import System.Process.Quick.CallSpec.Run as M import System.Process.Quick.CallSpec.Subcases as M import System.Process.Quick.CallSpec.Verify as M diff --git a/src/System/Process/Quick/CallArgument.hs b/src/System/Process/Quick/CallArgument.hs --- a/src/System/Process/Quick/CallArgument.hs +++ b/src/System/Process/Quick/CallArgument.hs @@ -3,7 +3,9 @@ import Control.Monad.Writer.Strict import Data.HList import Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax qualified as TH import Refined as M hiding (NonEmpty) +import System.Process.Quick.CallEffect import System.Process.Quick.OrphanArbitrary () import System.Process.Quick.Prelude hiding (Text) import TH.Utilities qualified as TU @@ -49,6 +51,7 @@ instance Quote QR where newName n = QR $ lift (newName n) +-- data class (Typeable a) => CallArgumentGen a where -- | field name in the record; constant value does not have a field cArgName :: a -> Maybe String @@ -57,13 +60,33 @@ progArgExpr :: a -> QR Exp -- | TH field definition of call argument in CallSpec record fieldExpr :: a -> QR (Maybe VarBangType) + -- | Exp type is '\v -> [OutcomeChecker]' + outcomeCheckersExpr :: a -> QR Exp + outcomeCheckersExpr _ = [| const [] |] + -- | Exp type is '\v -> m [CsBox]' + initCallSpecsExpr :: a -> QR Exp -newtype ConstArg = ConstArg String deriving (Eq, Show, Typeable) +instance CallArgumentGen OutcomeChecker where + cArgName _ = Nothing + progArgExpr _ = [| const [] |] + fieldExpr _ = pure Nothing + outcomeCheckersExpr c = [| pure [$(TH.lift c)] |] + initCallSpecsExpr _ = [| pure . const [] |] + +newtype ConstArg = ConstArg String deriving (Eq, Show) instance CallArgumentGen ConstArg where cArgName _ = Nothing progArgExpr (ConstArg c) = [| const [ $(stringE c)] |] fieldExpr _ = pure Nothing + initCallSpecsExpr _ = [| pure . const [] |] +newtype ConstArgs = ConstArgs [String] deriving (Eq, Show) +instance CallArgumentGen ConstArgs where + cArgName _ = Nothing + progArgExpr (ConstArgs cs) = [| const $(TH.lift cs) |] + fieldExpr _ = pure Nothing + initCallSpecsExpr _ = [| pure . const [] |] + defaultBang :: Bang defaultBang = Bang NoSourceUnpackedness NoSourceStrictness @@ -96,7 +119,7 @@ | otherwise -> filteredFieldName -- | Command line argument without preceeding key -newtype VarArg a = VarArg String deriving (Eq, Show, Typeable) +newtype VarArg a = VarArg String deriving (Eq, Show) instance (Typeable a, CallArgument a) => CallArgumentGen (VarArg a) where cArgName (VarArg n) = Just n progArgExpr (VarArg fieldName) = @@ -106,11 +129,13 @@ Just . (mkName $ escapeFieldName fieldName, defaultBang,) <$> atRep where atRep = QR . lift $ TU.typeRepToType (typeRep (Proxy @a)) + initCallSpecsExpr _ = [| pure . const [] |] -- | Command line argument prefixed with a key -newtype KeyArg a = KeyArg String deriving (Eq, Show, Typeable) +newtype KeyArg a = KeyArg String deriving (Eq, Show) instance (Typeable a, CallArgument a) => CallArgumentGen (KeyArg a) where cArgName (KeyArg n) = cArgName (VarArg @a n) progArgExpr (KeyArg fieldName) = [| \x -> $(progArgExpr (ConstArg fieldName)) x <> $(progArgExpr (VarArg @a fieldName)) x |] fieldExpr (KeyArg fieldName) = fieldExpr (VarArg @a fieldName) + initCallSpecsExpr _ = [| pure . const [] |] diff --git a/src/System/Process/Quick/CallEffect.hs b/src/System/Process/Quick/CallEffect.hs --- a/src/System/Process/Quick/CallEffect.hs +++ b/src/System/Process/Quick/CallEffect.hs @@ -1,10 +1,21 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + module System.Process.Quick.CallEffect where -import System.Posix + +import System.Directory ( doesDirectoryExist, doesFileExist ) +import System.Posix ( FileMode ) import System.Process.Quick.Prelude import Text.Regex.TDFA -import Prelude (Show (..)) + ( RegexLike(matchTest), + RegexMaker(makeRegexOpts), + RegexOptions(defaultCompOpt), + CompOption(multiline), + ExecOption(ExecOption), + Regex ) +import Language.Haskell.TH.Syntax ( Lift ) + data TimeReference = LaunchTime | BootTime @@ -26,34 +37,69 @@ | FsOr [FsEffect] deriving (Show, Eq) -data ViRex = ViRex ByteString Regex - -instance Show ViRex where - show (ViRex bs _) = Prelude.show bs - -instance Eq ViRex where - (ViRex a _) == (ViRex b _) = a == b - -data OutMatcher - = ExactMatching ByteString - | WholeMatching ViRex -- read all input - | LineMatching ViRex -- consume file line by line - at least one line match - deriving (Show, Eq) +data Mismatch a + = Mismatch + { expected :: a + , got ::a + } deriving (Show, Eq) data CallEffect = SleepFor Integer -- call lasts at least N microseconds - | ExitCode Int -- expected exit code + | ExitCode (Mismatch ExitCode) -- expected exit code | FsEffect FsEffect | OrCe [CallEffect] | AndCe [CallEffect] | NotCe [CallEffect] - | StdOutputCe OutMatcher - | StdErrorCe OutMatcher + | StdOutputCe { rx :: String, output :: String } + | StdErrorCe { rx :: String, output :: String } deriving (Show, Eq) --- | instances are generated for types with CallSpec and Subcases --- The class is introduced because, --- expected effects don't have fields in a CallSpec record -class CallSpecEffect cse where - -- call after callSpec in the same directory - unsatisfiedEffects :: MonadIO m => cse -> m [CallEffect] +-- move to module for orphan instances +deriving instance Lift ExitCode +deriving instance Data ExitCode + +data CsExecReport + = CsExecReport + { exitCode :: ExitCode + , stdErr :: String + , stdOut :: String + , execTime :: NominalDiffTime + , processDir :: FilePath + } deriving (Show, Eq) + +class CallSpecOutcomeCheck c where + -- | call after callSpec in the same directory + check :: MonadIO m => CsExecReport -> c -> m [CallEffect] + +data OutcomeChecker + = ExitCodeEqualTo ExitCode + | StdErrMatches String + | StdOutMatches String + | FileCreated FilePath + | DirCreated FilePath + deriving (Show, Eq, Data, Generic, Lift) + -- | ConcatOutcomeChecker [OutcomeChecker] + -- | BothOutcomeChecker OutcomeChecker OutcomeChecker + +parseRx :: String -> Regex +parseRx = makeRegexOpts defaultCompOpt { multiline = False } (ExecOption False) + +instance CallSpecOutcomeCheck OutcomeChecker where + check cser | $(tr "/cser") True = \case + ExitCodeEqualTo eec + | eec == exitCode cser -> pure [] + | otherwise -> pure [ExitCode . Mismatch eec $ exitCode cser] + StdErrMatches rx + | parseRx rx `matchTest` stdErr cser -> pure [] + | otherwise -> pure [StdErrorCe rx $ stdErr cser] + StdOutMatches rx + | parseRx rx `matchTest` stdOut cser -> pure [] + | otherwise -> pure [StdOutputCe rx $ stdOut cser] + FileCreated dp -> + liftIO (doesFileExist dp) >>= \case + True -> pure [] + False -> pure [FsEffect $ FsPathPredicate dp [FsExists]] + DirCreated dp -> + liftIO (doesDirectoryExist dp) >>= \case + True -> pure [] + False -> pure [FsEffect $ FsPathPredicate dp [FsExists]] diff --git a/src/System/Process/Quick/CallSpec.hs b/src/System/Process/Quick/CallSpec.hs --- a/src/System/Process/Quick/CallSpec.hs +++ b/src/System/Process/Quick/CallSpec.hs @@ -15,9 +15,11 @@ import System.Directory import System.Process.Quick.CallArgument import System.Process.Quick.CallSpec.Type as E +import System.Process.Quick.CallSpec.Verify.ImportOverlook import System.Process.Quick.Prelude import Text.Casing import Text.Regex +import System.Process.Quick.Util type FoldrConstr l a = (HFoldr (Mapcar (Fun CallArgumentGen (QR a))) [QR a] l [QR a]) @@ -59,6 +61,10 @@ , funD' 'programArgs [] [| concat . flap $(listE (hMapM (Fun progArgExpr :: Fun CallArgumentGen (QR Exp)) l)) |] , funD' 'verificationMethods [ [p|_|] ] (THS.lift $ sort verMethods) + , funD' 'outcomeCheckers [] + [| concat . flap $(listE (hMapM (Fun outcomeCheckersExpr :: Fun CallArgumentGen (QR Exp)) l)) |] + , funD' 'initCallSpecs [] + [| fmap concat . sequence . flap $(listE (hMapM (Fun initCallSpecsExpr :: Fun CallArgumentGen (QR Exp)) l)) |] ] mkName' :: NonEmptyStr -> Name @@ -70,10 +76,13 @@ [VerificationMethod] -> String -> HList l -> Q [Dec] genCallSpec verMethods progName l = do runIO . whenNothingM_ (findExecutable progName) . fail $ "Program " <> show progName <> " is not found" - maybe err (g . mkName') (programNameToHsIdentifier progName) + pkgName <- loc_module <$> location + addCompiledCallSpec (ConT . mkName . joinNe pkgName '.' $ toList csBaseName) + go $ mkName' csBaseName where - err = fail $ "Call spec name is bad: " <> show progName <> " " <> show l - g recName = do + csBaseName = maybe err id (programNameToHsIdentifier progName) + err = error $ "Call spec name is bad: " <> show progName <> " " <> show l + go recName = do (a, w) <- runWriterT . unQR $ sequence [ genCallArgsRecord recName l , genCallSpecInstance verMethods recName progName l diff --git a/src/System/Process/Quick/CallSpec/Init.hs b/src/System/Process/Quick/CallSpec/Init.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Quick/CallSpec/Init.hs @@ -0,0 +1,28 @@ +module System.Process.Quick.CallSpec.Init where + +import Language.Haskell.TH as TH +import System.Process.Quick.CallArgument +import System.Process.Quick.CallSpec +import System.Process.Quick.Prelude +import TH.Utilities qualified as TU + +data Init cs = Init deriving (Show, Eq, Ord, Data) + +instance CallSpec cs => CallArgumentGen (Init cs) where + cArgName _ = Nothing + -- Exp type is '\v -> [String]' + progArgExpr _ = [| const [] |] + fieldExpr _ = pure Nothing + -- | Exp type is '\v -> m [CsBox]' + initCallSpecsExpr _ = do + -- [| const (sequence [generate (arbitrary @cs)]) |] + trep <- QR $ lift $ TU.typeRepToType (typeRep (Proxy @cs)) + pure (AppE (VarE 'const) + (AppE (VarE 'liftIO) + (AppE (VarE 'sequence) + (ListE + [ AppE + (AppE (VarE 'fmap) (ConE 'CsBox)) + (AppE (VarE 'generate) + (AppTypeE (VarE 'arbitrary) trep)) + ])))) diff --git a/src/System/Process/Quick/CallSpec/Run.hs b/src/System/Process/Quick/CallSpec/Run.hs --- a/src/System/Process/Quick/CallSpec/Run.hs +++ b/src/System/Process/Quick/CallSpec/Run.hs @@ -4,22 +4,22 @@ import System.Process.Quick.CallSpec.Type import System.Process qualified as SP --- | See 'SP.callProcess' +-- | See 'System.Process.callProcess' callProcess :: (MonadIO m, CallSpec cs) => cs -> m () callProcess cs = liftIO $ SP.callProcess (programName $ pure cs) (programArgs cs) --- | See 'SP.spawnProcess' +-- | See 'System.Process.spawnProcess' spawnProcess :: (MonadIO m, CallSpec cs) => cs -> m SP.ProcessHandle spawnProcess cs = liftIO $ SP.spawnProcess (programName $ pure cs) (programArgs cs) --- | See 'SP.readProcess' +-- | See 'System.Process.readProcess' readProcess :: (MonadIO m, CallSpec cs) => cs -> String -> m String readProcess cs input = liftIO $ SP.readProcess (programName $ pure cs) (programArgs cs) input --- | See 'SP.readProcessWithExitCode' +-- | See 'System.Process.readProcessWithExitCode' readProcessWithExitCode :: (MonadIO m, CallSpec cs) => cs -> String -> m (ExitCode, String, String) readProcessWithExitCode cs input = liftIO $ SP.readProcessWithExitCode (programName $ pure cs) (programArgs cs) input --- | See 'SP.proc' +-- | See 'System.Process.proc' proc :: CallSpec cs => cs -> CreateProcess proc cs = SP.proc (programName $ pure cs) (programArgs cs) diff --git a/src/System/Process/Quick/CallSpec/Subcases.hs b/src/System/Process/Quick/CallSpec/Subcases.hs --- a/src/System/Process/Quick/CallSpec/Subcases.hs +++ b/src/System/Process/Quick/CallSpec/Subcases.hs @@ -59,10 +59,30 @@ , genArbitraryInstance (mkName tyCon) ] [| $(lamCasesE (subcaseToClause <$> cases)) . $(varE . mkName $ mapFirst toLower tyCon) |] - - fieldExpr (Subcases (TcName tyCon) _) = pure $ Just ( mkName $ mapFirst toLower tyCon , defaultBang , ConT $ mkName tyCon ) + outcomeCheckersExpr (Subcases (TcName tyCon) cases) = do + [| $(lamCasesE (subcaseToClause' <$> cases)) . $(varE . mkName $ mapFirst toLower tyCon) |] + where + subcaseToClause' :: Subcase -> QR Clause + subcaseToClause' (Subcase (DcName dcName) l) = do + x <- newName "x" + f <- [| concat . flap $(listE (hMapM (Fun outcomeCheckersExpr :: Fun CallArgumentGen (QR Exp)) l)) |] + pure $ Clause + [AsP x (RecP (mkName dcName) [])] + (NormalB (AppE f (VarE x))) + [] + initCallSpecsExpr (Subcases (TcName tyCon) cases) = do + [| $(lamCasesE (subcaseToClause' <$> cases)) . $(varE . mkName $ mapFirst toLower tyCon) |] + where + subcaseToClause' :: Subcase -> QR Clause + subcaseToClause' (Subcase (DcName dcName) l) = do + x <- newName "x" + f <- [| fmap concat . sequence . flap $(listE (hMapM (Fun initCallSpecsExpr :: Fun CallArgumentGen (QR Exp)) l)) |] + pure $ Clause + [AsP x (RecP (mkName dcName) [])] + (NormalB (AppE f (VarE x))) + [] diff --git a/src/System/Process/Quick/CallSpec/Type.hs b/src/System/Process/Quick/CallSpec/Type.hs --- a/src/System/Process/Quick/CallSpec/Type.hs +++ b/src/System/Process/Quick/CallSpec/Type.hs @@ -1,15 +1,24 @@ module System.Process.Quick.CallSpec.Type where +import System.Process.Quick.CallEffect ( OutcomeChecker ) import System.Process.Quick.Prelude -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax ( Lift ) -- | DC definition order defines validation order data VerificationMethod = TrailingHelpValidate | SandboxValidate - deriving (Show, Ord, Eq, Typeable, Data, Generic, Lift) + deriving (Show, Ord, Eq, Data, Bounded, Enum, Generic, Lift) -class (Arbitrary cs, Data cs) => CallSpec cs where +instance Pretty VerificationMethod where + pretty = show + +class (Show cs, Arbitrary cs, Data cs) => CallSpec cs where programName :: Proxy cs -> String programArgs :: cs -> [String] verificationMethods :: Proxy cs -> [VerificationMethod] + outcomeCheckers :: cs -> [OutcomeChecker] + initCallSpecs :: MonadIO m => cs -> m [CsBox] + +-- avoid UndecidableInstances for init dependent CallSpecs +data CsBox = forall cs. CallSpec cs => CsBox { unCsBox :: cs } diff --git a/src/System/Process/Quick/CallSpec/Verify.hs b/src/System/Process/Quick/CallSpec/Verify.hs --- a/src/System/Process/Quick/CallSpec/Verify.hs +++ b/src/System/Process/Quick/CallSpec/Verify.hs @@ -1,72 +1,44 @@ module System.Process.Quick.CallSpec.Verify where import Control.Monad.Writer.Strict hiding (lift) -import Data.Conduit ( runConduitRes, (.|) ) -import Data.Conduit.Find as F -import Data.Conduit.List qualified as DCL -import Debug.TraceEmbrace +import Data.Map qualified as M +import Data.Multimap.Table (row, rowKeys, rowKeysSet) +import Data.Set (findMin) +import Data.Text.Lazy qualified as LT +import System.Process.Quick.CallSpec.Verify.ImportOverlook import Language.Haskell.TH.Syntax -import System.Directory -import System.Exit hiding (exitFailure) -import System.FilePath (getSearchPath, takeDirectory, takeExtension) -import System.IO.Temp (withSystemTempDirectory) -import System.Process (readProcessWithExitCode) -import System.Process.Quick.CallEffect import System.Process.Quick.CallSpec -import System.Process.Quick.Predicate -import System.Process.Quick.Predicate.InFile () +import System.Process.Quick.CallSpec.Verify.Sandbox +import System.Process.Quick.CallSpec.Verify.TrailingHelp ( verifyTrailingHelp ) +import System.Process.Quick.CallSpec.Verify.Type +import System.Process.Quick.Predicate (ArgCollector, RefinedInArgLocator(..), RefinedOutArgLocator(..)) import System.Process.Quick.Predicate.InDir () +import System.Process.Quick.Predicate.InFile () import System.Process.Quick.Prelude hiding (Type, lift) - - -type FailureReport = Doc - -data CallSpecViolation - = HelpKeyIgnored - | HelpKeyNotSupported FailureReport - | ProgramNotFound FailureReport [FilePath] - | HelpKeyExitNonZero FailureReport - | SandboxLaunchFailed FailureReport - | UnexpectedCallEffect [CallEffect] - deriving (Show, Eq) - -data CsViolationWithCtx - = forall cs. CallSpec cs - => CsViolationWithCtx - { csContext :: cs - , csViolation :: CallSpecViolation - } - -type M m = (MonadMask m, MonadCatch m, MonadIO m) +import System.Process.Quick.Prelude qualified as P +import System.Process.Quick.Util ( M ) +import Text.Pretty.Simple -callProcessSilently :: M m => FilePath -> [String] -> m (Maybe Doc) -callProcessSilently p args = - tryIO (liftIO (readProcessWithExitCode p args "")) >>= \case - Left e -> - pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$ - "Failed due:" $$ tab e - - Right (ExitSuccess, _, _) -> pure Nothing - Right (ExitFailure ec, out, err) -> - pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$ - (if ec > 1 then "Exited with: " <> show ec $$ "" else "") - <> out &! (("Output: " <+>) . tab) <> err &! (("StdErr: " <+>) . tab) - verifyWithActiveMethods :: - forall w m cs. (M m, CallSpec cs, WriterT [FilePath] m ~ w) => + forall w m cs. (M m, CallSpec cs, WriterT [FilePath] (CsPerfT m) ~ w) => ArgCollector w -> ArgCollector w -> Set VerificationMethod -> Proxy cs -> Int -> - m [CsViolationWithCtx] + CsPerfT m [CsViolationWithCtx] verifyWithActiveMethods inArgLocators outArgLocators activeVerMethods pcs iterations = catMaybes <$> mapM go (filter (`member` activeVerMethods) (verificationMethods pcs)) where + go :: VerificationMethod -> CsPerfT m (Maybe CsViolationWithCtx) go = \case - TrailingHelpValidate -> verifyTrailingHelp pcs iterations - SandboxValidate -> validateInSandbox inArgLocators outArgLocators pcs iterations + TrailingHelpValidate -> + measureX pcs TrailingHelpValidate #csTotalTime $ + P.lift (verifyTrailingHelp pcs iterations) + SandboxValidate -> + measureX pcs SandboxValidate #csTotalTime $ + validateInSandbox inArgLocators outArgLocators (generate (arbitrary @cs)) iterations -- |Compose a list of monadic actions into one action. Composes using -- ('>=>') - that is, the output of each action is fed to the input of @@ -74,139 +46,89 @@ concatM :: (Monad m) => [a -> m a] -> (a -> m a) concatM fs = foldr (>=>) return fs -validateInSandbox :: - forall w m cs. (M m, CallSpec cs, WriterT [FilePath] m ~ w) => - ArgCollector w -> - ArgCollector w -> - Proxy cs -> - Int -> - m (Maybe CsViolationWithCtx) -validateInSandbox inArgLocators outArgLocators pcs !iterations - | iterations <= 0 = pure Nothing - | otherwise = - withSystemTempDirectory "quick-process" go >>= \case - Nothing -> validateInSandbox inArgLocators outArgLocators pcs $ iterations - 1 - Just e -> pure $ Just e - where - checkFilesExist cs outFiles = do - filterM (pure . not <=< doesFileExist) outFiles >>= \case - [] -> pure Nothing - ne -> pure . Just . CsViolationWithCtx cs $ - UnexpectedCallEffect - [ FsEffect . FsAnd $ fmap (FsNot . flip FsPathPredicate [FsExists]) ne - ] +formatPerfReportLine :: (TypeRep, CsPerf) -> Doc +formatPerfReportLine (typR, csp) = + hsep [ fill 29 $ pretty typR + , fill 15 . pretty . getSum $ csTotalTime csp + -- , pretty $ (getSum (csExeTime csp <> csGenerationTime csp) `div` iterations + , fill 15 . pretty . getSum $ csGenerationTime csp + , fill 15 . pretty . getSum $ csExeTime csp + ] - findOriginFor projectDir inFile = do - xs :: [FilePath] <- runConduitRes $ - F.find projectDir (do ignoreVcs - glob $ "*" <> takeExtension inFile - regular - not_ F.executable) .| DCL.consume - case xs of - [] -> pure Nothing - neXs -> Just <$> generate (elements neXs) +reportFor :: MonadIO m => VerificationMethod -> CsPerfT m Doc +reportFor vm = do + perfStats <- get + pure $ tab (linebreak <+> "*** Method: " <+> pretty vm <> linebreak <> + hsep [ fill 29 "Call Spec" + , fill 15 "Total" + , fill 15 "Generation" + , fill 15 "Execution" + ] $$ + "=======================================================================" $$ + (vcat . fmap formatPerfReportLine . reverse . sortWith (^. _2) . M.toList $ row vm perfStats) + ) <> linebreak - genInputFile projectDir inFile = (fromMaybe "/etc/hosts" <$> findOriginFor projectDir inFile) >>= - \origin -> createDirectoryIfMissing True (takeDirectory inFile) >> - copyFile origin inFile - -- putStrLn ("File " <> show origin <> " => " <> show inFile) - doIn projectDir () = do - cs <- liftIO (generate (arbitrary @cs)) - inFiles <- execWriterT (gmapM inArgLocators cs) - -- absolute path is an issue for generator - -- though process in docker is run under root - high chance to pass ;) - -- quick hack is to use odd size in Gen to avoid absolute path it Sandbox mode - mapM_ (liftIO1 (genInputFile projectDir)) inFiles - callProcessSilently (programName (pure cs)) (programArgs cs) >>= \case - Nothing -> do - outFiles <- execWriterT (gmapM outArgLocators cs) - liftIO (checkFilesExist cs outFiles) - Just e -> pure . Just . CsViolationWithCtx cs $ SandboxLaunchFailed e - go tdp = do - projectDir <- liftIO getCurrentDirectory - bracket - (liftIO $ setCurrentDirectory tdp) - (\() -> liftIO $ setCurrentDirectory projectDir) - (doIn projectDir) - -verifyTrailingHelp :: - forall m cs. (M m, CallSpec cs) => - Proxy cs -> - Int -> - m (Maybe CsViolationWithCtx) -verifyTrailingHelp pcs iterations = - liftIO (findExecutable progName) >>= \case - Nothing -> do - cs <- genCs - Just . CsViolationWithCtx cs . ProgramNotFound (text progName) <$> liftIO getSearchPath - Just _ -> do - spCmd progName helpKey - (spCmd progName ("--hheellppaoesnthqkxsth" : helpKey) - (do cs <- genCs - pure . Just $ CsViolationWithCtx cs HelpKeyIgnored) - (\_ -> go iterations)) - (\rep -> do - cs <- genCs - pure . Just . CsViolationWithCtx cs $ HelpKeyNotSupported rep) - where - progName = programName pcs - genCs = liftIO (generate (arbitrary @cs)) - helpKey = ["--help"] - spCmd pn args onSuccess onFailure = do - liftIO $(trIo "spawn process/pn args") - callProcessSilently pn args >>= \case - Nothing -> onSuccess - Just rep -> onFailure rep - go n - | n <= 0 = pure Nothing - | otherwise = do - cs <- liftIO (generate (arbitrary @cs)) - spCmd (programName pcs) (programArgs cs <> helpKey) - (go $ n - 1) - (\rep -> pure . Just . CsViolationWithCtx cs $ HelpKeyExitNonZero rep) - +consumeViolations :: MonadIO m => Int -> [CsViolationWithCtx] -> CsPerfT m () +consumeViolations iterations = \case + [] -> do + perfStats <- get + reports <- mapM reportFor $ rowKeys perfStats + printDoc $ "All of" <+> pretty (M.size $ row (findMin $ rowKeysSet perfStats) perfStats) + <+> "CallSpecs are valid due " + <+> pretty iterations <+> "tests executed for each" <> fold reports -consumeViolations :: MonadIO m => [CsViolationWithCtx] -> m () -consumeViolations = \case - [] -> - putStrLn "CallSpecs are valid" vis -> do let dashes = "-------------------------------------------------------------" -- good case for hetftio ?? - printDoc $ "Error: quick-process found " <> doc (length vis) <> " failed call specs:" - $$ (vcat $ zipWith (\i v -> tab ("-- [" <> doc i <> "] " <> dashes $$ printViolation v)) + printDoc $ "Error: quick-process found" <+> doc (length vis) <+> "failed call specs:" + $$ (vcat $ zipWith (\i v -> tab ("-- [" <> doc i <> "]" <+> dashes $$ printViolation v)) [1::Int ..] (sortByProgamName vis)) - <> "---------" <> dashes $$ "End of quick-process violation report" + $$ "-------" <> dashes $$ "End of quick-process violation report" <> linebreak exitFailure where sortByProgamName = sortWith (\(CsViolationWithCtx x _) -> programName $ pure x) printViolation (CsViolationWithCtx cs v) = - case v of - HelpKeyIgnored -> (text . programName $ pure cs) <> ": help key ignored" - ProgramNotFound report' pathCopy -> - "[" <> (text . programName $ pure cs) <> "] is not found on PATH:" $$ tab (vsep pathCopy) - $$ "Report:" $$ tab report' $$ "" - HelpKeyNotSupported report' -> - "--help key is not supported by [" <> (text . programName $ pure cs) <> "]" - $$ "Report:" $$ tab report' - HelpKeyExitNonZero rep -> - (text . programName $ pure cs) <> " - non zero exit code:" $$ tab rep - SandboxLaunchFailed rep -> - (text . programName $ pure cs) <> " - non zero exit code:" $$ tab rep - UnexpectedCallEffect uce -> do - (text . programName $ pure cs) <> ": has unsafisfied effects:" $$ (text $ show uce) - $$ "With arguments: " <> tab (programArgs cs) + let pn = (text . toLazy . toText . programName $ pure cs) in + case v of + HelpKeyIgnored -> pn <> ": help key ignored" + ProgramNotFound report' pathCopy -> + "[" <> pn <> "] is not found on PATH:" $$ tab (vsep pathCopy) + $$ "Report:" $$ tab report' + HelpKeyNotSupported report' -> + "--help key is not supported by [" <> pn <> "]" + $$ "Report:" $$ tab report' + HelpKeyExitNonZero rep -> + pn <> " - non zero exit code:" $$ tab rep + ExceptionThrown e -> + "Launch of " <> pn <> " - thrown exception:" $$ tab (text $ show e) + $$ "With arguments: " <> tab (programArgs cs) + UnexpectedCallEffect uce -> do + pn <> ": has unsafisfied effects:" $$ (vsep . fmap text . LT.lines $ pShow uce) + $$ "With arguments: " <> tab (programArgs cs) discoverAndVerifyCallSpecs :: Set VerificationMethod -> Int -> Q Exp discoverAndVerifyCallSpecs activeVerMethods iterations = do + startedAt <- runIO currentTime inArgLocators <- extractInstanceType <$> reifyInstances ''RefinedInArgLocator [VarT (mkName "b")] when (inArgLocators == []) $ putStrLn "Discovered 0 InArg locators!!!" outArgLocators <- extractInstanceType <$> reifyInstances ''RefinedOutArgLocator [VarT (mkName "c")] when (outArgLocators == []) $ putStrLn "Discovered 0 OutArg locators!!!" ts <- extractInstanceType <$> reifyInstances ''CallSpec [VarT (mkName "a")] - when (ts == []) $ putStrLn "Discovered 0 types with CallSpec instance!!!" - [| fmap concat (sequence $(ListE <$> (mapM (genCsVerification inArgLocators outArgLocators) ts))) >>= consumeViolations |] + when (ts == []) $ fail "Discovered 0 types with CallSpec instance!!!" + overlookedCss <- verifyFoundCsCoverCompiledOnes ts + when (overlookedCss /= mempty) . fail . toString . displayT . renderOneLine $ + "Overlooked CallSpecs: " <> pretty overlookedCss + !r <- [| void $ runStateT ( + fmap concat + (sequence $(ListE <$> (mapM (genCsVerification + inArgLocators outArgLocators) ts))) >>= + consumeViolations $(lift iterations)) + mempty + |] + endedAt <- runIO currentTime + putStrLn $ "discoverAndVerifyCallSpecs generation took " <> show (endedAt `diffUTCTime` startedAt) + pure r where getLocator n t = AppE (VarE n) (SigE (ConE 'Proxy) (AppT (ConT ''Proxy) t)) diff --git a/src/System/Process/Quick/CallSpec/Verify/ImportOverlook.hs b/src/System/Process/Quick/CallSpec/Verify/ImportOverlook.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Quick/CallSpec/Verify/ImportOverlook.hs @@ -0,0 +1,29 @@ +module System.Process.Quick.CallSpec.Verify.ImportOverlook + ( addCompiledCallSpec + , verifyFoundCsCoverCompiledOnes + ) where + +import Data.Set ( (\\), insert ) +import Language.Haskell.TH ( Type, Name, nameModule, nameBase, mkName ) +import System.Process.Quick.Prelude hiding (Type) +import System.Process.Quick.Util + +erasePackage :: Type -> Type +erasePackage t = gmapT go t + where + go :: forall x. (Data x) => x -> x + go x | Just Refl <- eqT @x @Name = + mkName $ joinNe (fromMaybe "" $ nameModule x) '.' (nameBase x) + | otherwise = x + +compiledCallSpecs :: IORef (Set Type) +compiledCallSpecs = unsafePerformIO $ newIORef mempty + +addCompiledCallSpec :: MonadIO m => Type -> m () +addCompiledCallSpec xt = atomicModifyIORef'_ compiledCallSpecs $ $(tw "/") . insert (erasePackage xt) + +verifyFoundCsCoverCompiledOnes :: MonadIO m => [Type] -> m (Set Type) +verifyFoundCsCoverCompiledOnes found = + (\\ fromList found') <$> readIORef compiledCallSpecs + where + found' = erasePackage <$> found diff --git a/src/System/Process/Quick/CallSpec/Verify/Sandbox.hs b/src/System/Process/Quick/CallSpec/Verify/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Quick/CallSpec/Verify/Sandbox.hs @@ -0,0 +1,141 @@ +module System.Process.Quick.CallSpec.Verify.Sandbox where + +import Data.Conduit (runConduitRes, (.|)) +import Data.Conduit.Find as F +import Data.Conduit.List qualified as DCL +import Data.Multimap.Table qualified as T +import System.Directory +import System.FilePath (takeDirectory, takeExtension) +import System.IO.Temp (withSystemTempDirectory) +import System.Process +import System.Process.Quick.CallEffect +import System.Process.Quick.CallSpec +import System.Process.Quick.CallSpec.Verify.Type +import System.Process.Quick.Predicate +import System.Process.Quick.Predicate.InDir () +import System.Process.Quick.Predicate.InFile () +import System.Process.Quick.Prelude hiding (Type, lift) +import System.Process.Quick.Util + + +callProcessAndReport :: (CallSpec cs, M m) => cs -> m CsExecReport +callProcessAndReport cs = do + proLaunchDir <- liftIO getCurrentDirectory + startedAt <- currentTime + liftIO (readProcessWithExitCode (programName (pure cs)) (programArgs cs) "") >>= \(ec, out, err) -> do + endedAt <- currentTime + pure CsExecReport + { exitCode = ec + , stdErr = err + , stdOut = out + , execTime = endedAt `diffUTCTime` startedAt + , processDir = proLaunchDir + } + +normalizeOutcomeChecks :: CallSpec cs => cs -> [OutcomeChecker] +normalizeOutcomeChecks cs = + case filter ecP origOutcomeChecks of + [] -> ExitCodeEqualTo ExitSuccess : origOutcomeChecks + [ExitCodeEqualTo ExitSuccess] -> + $(tr "!ExitCodeEqualTo ExitSuccess check is redundant/cs") + origOutcomeChecks + [ExitCodeEqualTo _] -> origOutcomeChecks + _ -> + $(tr "!Multiple ExitCodeEqualTo checks/cs") + origOutcomeChecks + where + origOutcomeChecks = outcomeCheckers cs + ecP = \case ExitCodeEqualTo _ -> True ; _ -> False + + +measureX :: forall m cs a. (Typeable cs, M m) => + Proxy cs -> VerificationMethod -> Lens' CsPerf (Sum NominalDiffTime) -> CsPerfT m a -> CsPerfT m a +measureX pcs vm l a = do + started <- currentTime + !r <- a + ended <- currentTime + modify' $ T.alter (merge ended started) vm (typeRep pcs) + pure r + where + merge e s = pure . (l .~ (Sum $ e `diffUTCTime` s)) . fromMaybe mempty + +validateInSandbox :: + forall w m cs. (M m, CallSpec cs, WriterT [FilePath] (CsPerfT m) ~ w) => + ArgCollector w -> + ArgCollector w -> + (IO cs) -> + Int -> + CsPerfT m (Maybe CsViolationWithCtx) +validateInSandbox inArgLocators outArgLocators mkCs !iterations + | iterations <= 0 = pure Nothing + | otherwise = + withSystemTempDirectory "quick-process" go >>= \case + Nothing -> validateInSandbox inArgLocators outArgLocators mkCs $ iterations - 1 + Just e -> pure $ Just e + where + validateInit cs projectDir (CsBox h:initCss) + = validateInSandboxOne projectDir inArgLocators outArgLocators (pure h) >>= \case + Nothing -> validateInit cs projectDir initCss + Just e -> pure $ Just e + validateInit cs projectDir [] + = validateInSandboxOne projectDir inArgLocators outArgLocators (pure cs) + doIn projectDir () = do + cs <- liftIO mkCs + validateInit cs projectDir =<< initCallSpecs cs + go tdp = do + projectDir <- liftIO getCurrentDirectory + bracket + (liftIO $ setCurrentDirectory tdp) + (\() -> liftIO $ setCurrentDirectory projectDir) + (doIn projectDir) + + +validateInSandboxOne :: + forall w m cs. (M m, CallSpec cs, WriterT [FilePath] (CsPerfT m) ~ w) => + FilePath -> + ArgCollector w -> + ArgCollector w -> + (IO cs) -> + CsPerfT m (Maybe CsViolationWithCtx) +validateInSandboxOne projectDir inArgLocators outArgLocators mkCs = doIn + where + checkFilesExist cs outFiles = do + filterM (pure . not <=< doesFileExist) outFiles >>= \case + [] -> pure Nothing + ne -> pure . Just . CsViolationWithCtx cs $ + UnexpectedCallEffect + [ FsEffect . FsAnd $ fmap (FsNot . flip FsPathPredicate [FsExists]) ne + ] + + findOriginFor inFile = do + xs :: [FilePath] <- runConduitRes $ + F.find projectDir (do ignoreVcs + glob $ "*" <> takeExtension inFile + regular + not_ F.executable) .| DCL.consume + case xs of + [] -> pure Nothing + neXs -> Just <$> generate (elements neXs) + + genInputFile inFile = (fromMaybe "/etc/hosts" <$> findOriginFor inFile) >>= + \origin -> createDirectoryIfMissing True (takeDirectory inFile) >> + copyFile origin inFile + -- putStrLn ("File " <> show origin <> " => " <> show inFile) + + doIn = do + let pcs = Proxy @cs + cs <- measureX pcs SandboxValidate #csGenerationTime (liftIO mkCs) + inFiles <- execWriterT (gmapM inArgLocators cs) + -- absolute path is an issue for generator + -- though process in docker is run under root - high chance to pass ;) + -- quick hack is to use odd size in Gen to avoid absolute path it Sandbox mode + mapM_ (liftIO1 genInputFile) inFiles + let nocs = normalizeOutcomeChecks cs + tryIO (measureX pcs SandboxValidate #csExeTime $ callProcessAndReport cs) >>= \case + Left e -> throw . CsViolationWithCtx cs . ExceptionThrown $ SomeException e + Right csr -> mapM (check csr) nocs >>= pure . concat >>= + \case + [] -> do + outFiles <- execWriterT (gmapM outArgLocators cs) + liftIO (checkFilesExist cs outFiles) + cfs -> pure . Just . CsViolationWithCtx cs $ UnexpectedCallEffect cfs diff --git a/src/System/Process/Quick/CallSpec/Verify/TrailingHelp.hs b/src/System/Process/Quick/CallSpec/Verify/TrailingHelp.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Quick/CallSpec/Verify/TrailingHelp.hs @@ -0,0 +1,52 @@ +module System.Process.Quick.CallSpec.Verify.TrailingHelp where + + +import Debug.TraceEmbrace ( trIo ) +import System.FilePath ( getSearchPath ) +import System.Directory ( findExecutable ) +import System.Process.Quick.CallSpec + ( CallSpec(programArgs, programName) ) +import System.Process.Quick.CallSpec.Verify.Type + ( CsViolationWithCtx(CsViolationWithCtx), + CallSpecViolation(HelpKeyNotSupported, HelpKeyExitNonZero, + ProgramNotFound, HelpKeyIgnored) ) +import System.Process.Quick.Predicate.InDir () +import System.Process.Quick.Predicate.InFile () +import System.Process.Quick.Prelude hiding (Type, lift) +import System.Process.Quick.Util ( callProcessSilently, M ) + +verifyTrailingHelp :: + forall m cs. (M m, CallSpec cs) => + Proxy cs -> + Int -> + m (Maybe CsViolationWithCtx) +verifyTrailingHelp pcs iterations = + liftIO (findExecutable progName) >>= \case + Nothing -> do + cs <- genCs + Just . CsViolationWithCtx cs . ProgramNotFound (text . toLazy $ toText progName) <$> liftIO getSearchPath + Just _ -> do + spCmd progName helpKey + (spCmd progName ("--hheellppaoesnthqkxsth" : helpKey) + (do cs <- genCs + pure . Just $ CsViolationWithCtx cs HelpKeyIgnored) + (\_ -> go iterations)) + (\rep -> do + cs <- genCs + pure . Just . CsViolationWithCtx cs $ HelpKeyNotSupported rep) + where + progName = programName pcs + genCs = liftIO (generate (arbitrary @cs)) + helpKey = ["--help"] + spCmd pn args onSuccess onFailure = do + liftIO $(trIo "spawn process/pn args") + callProcessSilently pn args >>= \case + Nothing -> onSuccess + Just rep -> onFailure rep + go n + | n <= 0 = pure Nothing + | otherwise = do + cs <- liftIO (generate (arbitrary @cs)) + spCmd (programName pcs) (programArgs cs <> helpKey) + (go $ n - 1) + (\rep -> pure . Just . CsViolationWithCtx cs $ HelpKeyExitNonZero rep) diff --git a/src/System/Process/Quick/CallSpec/Verify/Type.hs b/src/System/Process/Quick/CallSpec/Verify/Type.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Quick/CallSpec/Verify/Type.hs @@ -0,0 +1,52 @@ + +module System.Process.Quick.CallSpec.Verify.Type where + +import Data.Multimap.Table ( Table ) +import Generic.Data ( gmappend, gmempty ) +import Prelude (show) +import System.Process.Quick.CallEffect (CallEffect) +import System.Process.Quick.CallSpec.Type +import System.Process.Quick.Prelude hiding (show) + +type FailureReport = Doc + +data CallSpecViolation + = HelpKeyIgnored + | HelpKeyNotSupported FailureReport + | ProgramNotFound FailureReport [FilePath] + | HelpKeyExitNonZero FailureReport + | ExceptionThrown SomeException + | UnexpectedCallEffect [CallEffect] + deriving (Show) + +data CsViolationWithCtx + = forall cs. CallSpec cs + => CsViolationWithCtx + { csContext :: cs + , csViolation :: CallSpecViolation + } + +instance Show CsViolationWithCtx where + show (CsViolationWithCtx cs csv) = "CsViolationWithCtx " <> show cs <> " " <> show csv + +instance Exception CsViolationWithCtx + + +data CsPerf + = CsPerf + { csGenerationTime :: !(Sum NominalDiffTime) + , csTotalTime :: !(Sum NominalDiffTime) + , csExeTime :: !(Sum NominalDiffTime) + } deriving (Show, Eq, Generic) + +instance Ord CsPerf where + compare = comparing (^. #csTotalTime) + +instance Semigroup CsPerf where + (<>) = gmappend + +instance Monoid CsPerf where + mempty = gmempty + + +type CsPerfT m = StateT (Table VerificationMethod TypeRep CsPerf) m diff --git a/src/System/Process/Quick/Predicate/InDir.hs b/src/System/Process/Quick/Predicate/InDir.hs --- a/src/System/Process/Quick/Predicate/InDir.hs +++ b/src/System/Process/Quick/Predicate/InDir.hs @@ -1,12 +1,10 @@ module System.Process.Quick.Predicate.InDir where -import Data.Typeable (eqT) import System.Directory import System.Process.Quick.Predicate import System.Process.Quick.Predicate.InFile ( genFilePathBy ) import System.Process.Quick.Prelude import Text.Regex.TDFA ((=~)) -import Type.Reflection ((:~:)(Refl)) data InDir deriving (Data, Show, Eq, Generic) diff --git a/src/System/Process/Quick/Predicate/InFile.hs b/src/System/Process/Quick/Predicate/InFile.hs --- a/src/System/Process/Quick/Predicate/InFile.hs +++ b/src/System/Process/Quick/Predicate/InFile.hs @@ -1,6 +1,5 @@ module System.Process.Quick.Predicate.InFile where -import Control.Monad.Writer.Strict import System.Process.Quick.Predicate import System.Process.Quick.Prelude import System.Process.Quick.TdfaToSbvRegex as P @@ -8,8 +7,6 @@ import System.Process.Quick.CallArgument (NeList) import Text.Regex.TDFA ((=~)) import Type.Reflection qualified as R -import Type.Reflection ((:~:)(Refl)) -import Data.Typeable (eqT) data InFile (ext :: Symbol) deriving (Data, Show, Eq, Generic) diff --git a/src/System/Process/Quick/Prelude.hs b/src/System/Process/Quick/Prelude.hs --- a/src/System/Process/Quick/Prelude.hs +++ b/src/System/Process/Quick/Prelude.hs @@ -1,21 +1,29 @@ {-# OPTIONS_HADDOCK hide #-} module System.Process.Quick.Prelude (module M, liftIO1) where -import Control.Exception.Safe as M (MonadMask, MonadCatch, bracket, tryIO, try, tryAny) -import Data.Data as M (Data, gmapM) +import Control.Monad.Writer.Strict as M (MonadWriter (tell), WriterT, execWriterT) +import Control.Exception.Safe as M (MonadMask, MonadCatch, bracket, tryIO, try, tryAny, throw) +import Control.Lens as M (Lens', at, (^.), (.~), (%~), _1, _2) +import Control.Monad.Time as M (MonadTime(..)) import Data.Char as M (isAlphaNum, isAlpha, isLetter, isLower, toLower) +import Data.Data as M (Data, gmapM, gmapT) +import Data.Generics.Labels as M () import Data.HList as M (typeRep) import Data.List as M (isSuffixOf) import Data.Set as M (member) +import Data.Time.Clock as M (NominalDiffTime, diffUTCTime) +import Data.Typeable as M (TypeRep, eqT, (:~:) (Refl)) +import Debug.TraceEmbrace as M (tr, tw) import Generic.Random as M (genericArbitraryU) +import GHC.TypeLits as M (Symbol, KnownSymbol (..), symbolVal) +import Refined as M (Refined, unrefine, refine, Predicate (..), throwRefineOtherException) import Relude as M hiding (Predicate) import Relude.Extra as M (toPairs) -import Test.QuickCheck as M (Gen, Arbitrary (..), generate, chooseInt, sized, elements, listOf) -import System.Process.Quick.Pretty as M -import System.Process as M (ProcessHandle, CreateProcess (..), readCreateProcess, readCreateProcessWithExitCode) import System.Exit as M (ExitCode (..)) -import Refined as M (Refined, unrefine, refine, Predicate (..), throwRefineOtherException) -import GHC.TypeLits as M (Symbol, KnownSymbol (..), symbolVal) +import System.IO.Unsafe as M (unsafePerformIO) +import System.Process as M (ProcessHandle, CreateProcess (..), readCreateProcess, readCreateProcessWithExitCode) +import System.Process.Quick.Pretty as M +import Test.QuickCheck as M (Gen, Arbitrary (..), generate, chooseInt, sized, elements, listOf) liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b liftIO1 = (.) liftIO diff --git a/src/System/Process/Quick/Pretty.hs b/src/System/Process/Quick/Pretty.hs --- a/src/System/Process/Quick/Pretty.hs +++ b/src/System/Process/Quick/Pretty.hs @@ -1,6 +1,10 @@ +{-# OPTIONS_GHC -Wno-orphans #-} module System.Process.Quick.Pretty - ( Pretty (..) + ( doc + , hsep -- Pretty (..) + , vsep , (&!) + , ($$) , escArg , tab , printDoc @@ -8,40 +12,36 @@ , module PP ) where -import Control.Exception.Safe +import Data.Time ( NominalDiffTime ) +import Control.Exception ( IOException ) +import Data.Typeable import GHC.ResponseFile (escapeArgs) import Relude -import Text.PrettyPrint as PP hiding (hsep, (<>), empty, isEmpty) -import Text.PrettyPrint qualified as PP - - -class Pretty a where - default doc :: Show a => a -> Doc - doc = text . show - doc :: a -> Doc +import Text.PrettyPrint.Leijen.Text as PP hiding ((<$>), bool, group, hsep, vsep, empty, isEmpty) +import Text.PrettyPrint.Leijen.Text qualified as PP +import Language.Haskell.TH qualified as TH +-- import Language.Haskell.TH.Syntax (Type (..)) - hsep :: [a] -> Doc - hsep = PP.hsep . fmap doc - {-# INLINE hsep #-} +infixr 5 $$ +($$) :: Doc -> Doc -> Doc +($$) = (<$$>) - vsep :: [a] -> Doc - vsep = vcat . fmap doc - {-# INLINE vsep #-} +-- class Pretty a where +-- default doc :: Show a => a -> Doc +doc :: Pretty a => a -> Doc +doc = pretty -- . show +-- doc :: a -> Doc -instance Pretty Doc where - doc = id - {-# INLINE doc #-} -instance Pretty String where - doc = text - {-# INLINE doc #-} -instance Pretty IOException -instance Pretty Int -instance Pretty Integer -instance Pretty [String] +hsep :: Pretty a => [a] -> Doc +hsep = PP.hsep . fmap doc +{-# INLINE hsep #-} +vsep :: Pretty a => [a] -> Doc +vsep = vcat . fmap doc +{-# INLINE vsep #-} -printDoc :: MonadIO m => Doc -> m () -printDoc = putStrLn . render +printDoc :: (MonadIO m, Pretty a) => a -> m () +printDoc x = liftIO (putDoc $ pretty x) tab :: Pretty a => a -> Doc tab = nest 2 . doc @@ -66,3 +66,23 @@ escArg :: String -> String escArg = reverse . drop 1 . reverse . escapeArgs . pure + +instance Pretty IOException where + pretty = text . show + +instance Pretty TypeRep where + pretty tr = + let tc = typeRepTyCon tr in + text . toLText $ tyConModule tc <> "." <> tyConName tc + +instance Pretty TH.Type where + pretty = \case + TH.ConT tn -> + text . toLText . maybe (TH.nameBase tn) (<> "." <> TH.nameBase tn) $ TH.nameModule tn + o -> text $ show o + +instance Pretty a => Pretty (Set a) where + pretty x = "{" <+> hsep (toList x) <+> "}" + +instance Pretty NominalDiffTime where + pretty = text . show diff --git a/src/System/Process/Quick/Sbv/Arbitrary.hs b/src/System/Process/Quick/Sbv/Arbitrary.hs --- a/src/System/Process/Quick/Sbv/Arbitrary.hs +++ b/src/System/Process/Quick/Sbv/Arbitrary.hs @@ -1,10 +1,8 @@ module System.Process.Quick.Sbv.Arbitrary where import System.Process.Quick.Prelude -import Data.SBV -- (Satisfiable, SymVal, Modelable (..), SString, sat, (.==), (.&&), literal) +import Data.SBV import Data.SBV.String qualified as S --- import Data.SBV.Control qualified as C -import System.IO.Unsafe (unsafePerformIO) import Data.SBV.RegExp getSingleValue :: (SymVal b, Modelable m) => m -> Maybe b @@ -15,7 +13,6 @@ _ -> Nothing | otherwise = Nothing --- models satOne :: (Satisfiable a, SymVal b) => Int -> a -> Maybe b satOne _n p = unsafePerformIO (getSingleValue <$> sat p) @@ -23,12 +20,6 @@ satN n p = unsafePerformIO (mapMaybe getSingleValue . allSatResults <$> asat) where asat = allSatWith defaultSMTCfg { allSatMaxModelCount = Just n } p - --- satStateless :: SymVal a => Int -> a -> Symbolic (Either String b) --- satStateless seed p = unsafePerformIO go --- where --- solve :: --- go = runSMT solve findStringByRegex :: (SymVal b) => RegExp -> Gen b findStringByRegex r = go (3 :: Int) diff --git a/src/System/Process/Quick/Util.hs b/src/System/Process/Quick/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Process/Quick/Util.hs @@ -0,0 +1,25 @@ +module System.Process.Quick.Util where + +import Control.Monad.Writer.Strict hiding (lift) +import System.Exit hiding (exitFailure) +import System.Process +import System.Process.Quick.Prelude hiding (Type, lift) + +type M m = (MonadTime m, MonadMask m, MonadCatch m, MonadIO m) + +callProcessSilently :: M m => FilePath -> [String] -> m (Maybe Doc) +callProcessSilently p args = + tryIO (liftIO (readProcessWithExitCode p args "")) >>= \case + Left e -> + pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$ + "Failed due:" $$ tab e + + Right (ExitSuccess, _, _) -> pure Nothing + Right (ExitFailure ec, out, err) -> + pure . Just $ "Command: [" <> doc p <> " " <> hsep (escArg <$> args) <> "]" $$ + (if ec > 1 then "Exited with: " <> show ec $$ "" else "") + <> out &! (("Output: " <+>) . tab) <> err &! (("StdErr: " <+>) . tab) + +joinNe :: [a] -> a -> [a] -> [a] +joinNe _ _ [] = [] +joinNe p d s = p <> [d] <> s diff --git a/test/System/Process/Quick/Test/Prelude.hs b/test/System/Process/Quick/Test/Prelude.hs --- a/test/System/Process/Quick/Test/Prelude.hs +++ b/test/System/Process/Quick/Test/Prelude.hs @@ -1,6 +1,6 @@ module System.Process.Quick.Test.Prelude (module M) where -import Control.Lens as M ((^.), (^?), at, ix) +import Control.Lens as M ((^?), ix) import Data.HList as M (HList(..), HExtend(..)) import Refined as M (SizeEqualTo) import System.Directory as M (doesFileExist, removeFile) diff --git a/verify-call-specs/CallSpecs/Find.hs b/verify-call-specs/CallSpecs/Find.hs --- a/verify-call-specs/CallSpecs/Find.hs +++ b/verify-call-specs/CallSpecs/Find.hs @@ -8,4 +8,7 @@ type DirPath = Refined FsPath String -$(genCallSpec [TrailingHelpValidate] "find" (ConstArg "-H" .*. VarArg @DirPath "path" .*. KeyArg @NodeType "-type" .*. HNil)) +$(genCallSpec + [TrailingHelpValidate] + "find" + (ConstArg "-H" .*. VarArg @DirPath "path" .*. KeyArg @NodeType "-type" .*. HNil)) diff --git a/verify-call-specs/CallSpecs/Find/Type.hs b/verify-call-specs/CallSpecs/Find/Type.hs --- a/verify-call-specs/CallSpecs/Find/Type.hs +++ b/verify-call-specs/CallSpecs/Find/Type.hs @@ -3,7 +3,7 @@ import System.Process.Quick import System.Process.Quick.Prelude -data NodeType = FileNode | DirNode deriving (Show, Eq, Generic, Typeable, Data) +data NodeType = FileNode | DirNode deriving (Show, Eq, Generic, Data) instance Arbitrary NodeType where arbitrary = genericArbitraryU