diff --git a/Data/Vinyl/ARec/Internal.hs b/Data/Vinyl/ARec/Internal.hs index 79a6708..aedd098 100644 --- a/Data/Vinyl/ARec/Internal.hs +++ b/Data/Vinyl/ARec/Internal.hs @@ -69,12 +69,12 @@ import GHC.Types -- | An array-backed extensible record with constant-time field -- access. -newtype ARec (f :: k -> *) (ts :: [k]) = ARec SmallArray +newtype ARec (f :: k -> Type) (ts :: [k]) = ARec SmallArray type role ARec representational nominal -- | Get the ith element from the ARec unsafeIxARec - :: forall a k (f :: k -> *) (ts :: [k]). + :: forall a k (f :: k -> Type) (ts :: [k]). ARec f ts -> Int -> a diff --git a/Data/Vinyl/Class/Method.hs b/Data/Vinyl/Class/Method.hs index 212c72d..750124a 100644 --- a/Data/Vinyl/Class/Method.hs +++ b/Data/Vinyl/Class/Method.hs @@ -56,6 +56,7 @@ module Data.Vinyl.Class.Method -- * Example -- $example ) where +import Data.Kind import Data.Functor.Product (Product(Pair)) import Data.Vinyl.Core import Data.Vinyl.Derived (KnownField, AllFields, FieldRec, traverseField) @@ -140,7 +141,7 @@ recMaxBound (_ :& rs) = maxBound :& recMaxBound rs data FieldTyper = FieldId | FieldSnd -- | The interpretation function of the 'FieldTyper' symbols. -type family ApplyFieldTyper (f :: FieldTyper) (a :: k) :: * where +type family ApplyFieldTyper (f :: FieldTyper) (a :: k) :: Type where ApplyFieldTyper 'FieldId a = a ApplyFieldTyper 'FieldSnd a = Snd a @@ -149,13 +150,13 @@ type family ApplyFieldTyper (f :: FieldTyper) (a :: k) :: * where -- type, and 'Compose' to pick out the inner-most context. All other -- type constructor contexts are understood to not perform any -- computation on their arguments. -type family FieldPayload (f :: u -> *) :: FieldTyper where +type family FieldPayload (f :: u -> Type) :: FieldTyper where FieldPayload ElField = 'FieldSnd FieldPayload (f :. g) = FieldPayload g FieldPayload f = 'FieldId -- | Shorthand for combining 'ApplyFieldTyper' and 'FieldPayload'. -type family PayloadType f (a :: u) :: * where +type family PayloadType f (a :: u) :: Type where PayloadType f a = ApplyFieldTyper (FieldPayload f) a -- | Generate a record from fields derived from type class diff --git a/Data/Vinyl/CoRec.hs b/Data/Vinyl/CoRec.hs index 6a47b15..1050e80 100644 --- a/Data/Vinyl/CoRec.hs +++ b/Data/Vinyl/CoRec.hs @@ -12,6 +12,7 @@ -- of those three types, it is /any one/ of type @A@, @B@, /or/ -- @C@. The type @CoRec '[A,B,C]@ corresponds to this sum type. module Data.Vinyl.CoRec where +import Data.Kind import Data.Maybe(fromJust) import Data.Vinyl.Core import Data.Vinyl.Lens (RElem, rget, rput, type (∈)) @@ -19,12 +20,11 @@ import Data.Vinyl.Functor (Compose(..), (:.), Identity(..), Const(..)) import Data.Vinyl.TypeLevel import Data.Vinyl.Derived (FieldType, (:::)) import GHC.TypeLits (Symbol, KnownSymbol) -import GHC.Types (type Type) import Unsafe.Coerce (unsafeCoerce) -- | Generalize algebraic sum types. -data CoRec :: (k -> *) -> [k] -> * where +data CoRec :: (k -> Type) -> [k] -> Type where CoRec :: RElem a ts (RIndex a ts) => !(f a) -> CoRec f ts -- | A 'CoRec' constructor with better inference. If you have a label diff --git a/Data/Vinyl/Core.hs b/Data/Vinyl/Core.hs index f1a2296..b410021 100644 --- a/Data/Vinyl/Core.hs +++ b/Data/Vinyl/Core.hs @@ -61,7 +61,7 @@ import Data.Constraint.Forall (Forall) -- list of rows @rs@. The labels or indices of the record are given by -- inhabitants of the kind @u@; the type of values at any label @r :: u@ is -- given by its interpretation @f r :: *@. -data Rec :: (u -> *) -> [u] -> * where +data Rec :: (u -> Type) -> [u] -> Type where RNil :: Rec f '[] (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) @@ -346,11 +346,11 @@ instance (Semigroup (f r), Semigroup (Rec f rs)) instance Monoid (Rec f '[]) where mempty = RNil - RNil `mappend` RNil = RNil + mappend = (<>) instance (Monoid (f r), Monoid (Rec f rs)) => Monoid (Rec f (r ': rs)) where mempty = mempty :& mempty - (x :& xs) `mappend` (y :& ys) = (mappend x y) :& (mappend xs ys) + mappend = (<>) instance Eq (Rec f '[]) where _ == _ = True @@ -420,7 +420,7 @@ type family Head xs where type family Tail xs where Tail (_ ': xs) = xs -type family AllRepsMatch_ (f :: j -> *) (xs :: [j]) (g :: k -> *) (ys :: [k]) :: Constraint where +type family AllRepsMatch_ (f :: j -> Type) (xs :: [j]) (g :: k -> Type) (ys :: [k]) :: Constraint where AllRepsMatch_ f (x ': xs) g ys = ( ys ~ (Head ys ': Tail ys) , Coercible (f x) (g (Head ys)) @@ -455,7 +455,7 @@ repsMatchConvert (x :& xs) = coerce x :& repsMatchConvert xs consMatchCoercion :: (forall (x :: k). Coercible (f x) (g x)) => Coercion (Rec f xs) (Rec g xs) #else -consMatchCoercion :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]). +consMatchCoercion :: forall k (f :: k -> Type) (g :: k -> Type) (xs :: [k]). Forall (Similar f g) => Coercion (Rec f xs) (Rec g xs) #endif consMatchCoercion = unsafeCoerce (Coercion :: Coercion () ()) @@ -467,7 +467,7 @@ consMatchConvert RNil = RNil consMatchConvert (x :& xs) = coerce x :& consMatchConvert xs -- And for old GHC. -consMatchConvert' :: forall k (f :: k -> *) (g :: k -> *) (xs :: [k]). +consMatchConvert' :: forall k (f :: k -> Type) (g :: k -> Type) (xs :: [k]). Forall (Similar f g) => Rec f xs -> Rec g xs consMatchConvert' RNil = RNil consMatchConvert' ((x :: f x) :& xs) = @@ -498,6 +498,6 @@ consMatchCoercible :: forall k f g rep (r :: TYPE rep). consMatchCoercible f = case unsafeCoerce @(Zouch f f) @(Zouch f g) (Zouch $ \r -> r) of Zouch q -> q f -newtype Zouch (f :: k -> *) (g :: k -> *) = +newtype Zouch (f :: k -> Type) (g :: k -> Type) = Zouch (forall rep (r :: TYPE rep). ((forall (xs :: [k]). Coercible (Rec f xs) (Rec g xs)) => r) -> r) -} diff --git a/Data/Vinyl/Curry.hs b/Data/Vinyl/Curry.hs index c7cd581..9ac383e 100644 --- a/Data/Vinyl/Curry.hs +++ b/Data/Vinyl/Curry.hs @@ -12,6 +12,7 @@ records. -} module Data.Vinyl.Curry where +import Data.Kind import Data.Vinyl import Data.Vinyl.Functor import Data.Vinyl.XRec @@ -170,7 +171,7 @@ from arguments of type @f t@ for @t@ in @ts@, to a result of type @a@. CurriedF Maybe '[Int, Bool, String] Int :: * = Maybe Int -> Maybe Bool -> Maybe [Char] -> Int -} -type family CurriedF (f :: u -> *) (ts :: [u]) a where +type family CurriedF (f :: u -> Type) (ts :: [u]) a where CurriedF f '[] a = a CurriedF f (t ': ts) a = f t -> CurriedF f ts a @@ -183,6 +184,6 @@ from arguments of type @HKD f t@ for @t@ in @ts@, to a result of type @a@. CurriedX (Maybe :. Identity) '[Int, Bool, String] Int :: * = Maybe Int -> Maybe Bool -> Maybe [Char] -> Int -} -type family CurriedX (f :: u -> *) (ts :: [u]) a where +type family CurriedX (f :: u -> Type) (ts :: [u]) a where CurriedX f '[] a = a CurriedX f (t ': ts) a = HKD f t -> CurriedX f ts a diff --git a/Data/Vinyl/Derived.hs b/Data/Vinyl/Derived.hs index 6ed7582..75303ec 100644 --- a/Data/Vinyl/Derived.hs +++ b/Data/Vinyl/Derived.hs @@ -15,6 +15,7 @@ -- | Commonly used 'Rec' instantiations. module Data.Vinyl.Derived where +import Data.Kind import Data.Proxy import Data.Vinyl.ARec import Data.Vinyl.Core @@ -71,7 +72,7 @@ infix 8 =: -- | Operator for creating an 'ElField'. With the @-XOverloadedLabels@ -- extension, this permits usage such as, @#foo =: 23@ to produce a -- value of type @ElField ("foo" ::: Int)@. -(=:) :: KnownSymbol l => Label (l :: Symbol) -> (v :: *) -> ElField (l ::: v) +(=:) :: KnownSymbol l => Label (l :: Symbol) -> (v :: Type) -> ElField (l ::: v) _ =: v = Field v -- | Get a named field from a record. diff --git a/Data/Vinyl/FromTuple.hs b/Data/Vinyl/FromTuple.hs index 96bb3c7..e969535 100644 --- a/Data/Vinyl/FromTuple.hs +++ b/Data/Vinyl/FromTuple.hs @@ -14,6 +14,7 @@ -- example record construction using 'ElField' for named fields: -- @fieldRec (#x =: True, #y =: 'b') :: FieldRec '[ '("x", Bool), '("y", Char) ]@ module Data.Vinyl.FromTuple where +import Data.Kind import Data.Monoid (First(..)) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup (Semigroup(..)) @@ -29,7 +30,7 @@ import GHC.TypeLits (TypeError, ErrorMessage(Text)) -- type constructor to a tuple of the common type constructor and a -- list of the types to which it is applied in the original -- tuple. E.g. @TupleToRecArgs f (f a, f b) ~ (f, [a,b])@. -type family TupleToRecArgs f t = (r :: (u -> *, [u])) | r -> t where +type family TupleToRecArgs f t = (r :: (u -> Type, [u])) | r -> t where TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g, f h) = '(f, [a,b,c,d,e,z,g,h]) TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g) = '(f, [a,b,c,d,e,z,g]) @@ -42,12 +43,12 @@ type family TupleToRecArgs f t = (r :: (u -> *, [u])) | r -> t where -- | Apply the 'Rec' type constructor to a type-level tuple of its -- arguments. -type family UncurriedRec (t :: (u -> *, [u])) = r | r -> t where +type family UncurriedRec (t :: (u -> Type, [u])) = r | r -> t where UncurriedRec '(f, ts) = Rec f ts -- | Apply the 'XRec' type constructor to a type-level tuple of its -- arguments. -type family UncurriedXRec (t :: (u -> *, [u])) = r | r -> t where +type family UncurriedXRec (t :: (u -> Type, [u])) = r | r -> t where UncurriedXRec '(f, ts) = XRec f ts -- | Convert between an 'XRec' and an isomorphic tuple. @@ -90,7 +91,7 @@ instance TupleXRec f '[a,b,c,d,e,z,g,h] where (a, b, c, d, e, z, g, h) xrecX (a, b, c, d, e, z, g, h) = a ::& b ::& c ::& d ::& e ::& z ::& g ::& h ::& XRNil -type family ListToHKDTuple (f :: u -> *) (ts :: [u]) :: * where +type family ListToHKDTuple (f :: u -> Type) (ts :: [u]) :: Type where ListToHKDTuple f '[] = HKD f () ListToHKDTuple f '[a,b] = (HKD f a, HKD f b) ListToHKDTuple f '[a,b,c] = (HKD f a, HKD f b, HKD f c) diff --git a/Data/Vinyl/Functor.hs b/Data/Vinyl/Functor.hs index 179fd8a..2da1070 100644 --- a/Data/Vinyl/Functor.hs +++ b/Data/Vinyl/Functor.hs @@ -73,10 +73,10 @@ data Thunk a , Traversable ) -newtype Lift (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l') (x :: k) +newtype Lift (op :: l -> l' -> Type) (f :: k -> l) (g :: k -> l') (x :: k) = Lift { getLift :: op (f x) (g x) } -newtype Compose (f :: l -> *) (g :: k -> l) (x :: k) +newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k) = Compose { getCompose :: f (g x) } deriving (Storable, Generic) @@ -85,7 +85,7 @@ instance Semigroup (f (g a)) => Semigroup (Compose f g a) where instance Monoid (f (g a)) => Monoid (Compose f g a) where mempty = Compose mempty - mappend (Compose x) (Compose y) = Compose (mappend x y) + mappend = (<>) -- | Apply a function to a value whose type is the application of the -- 'Compose' type constructor. This works under the 'Compose' newtype @@ -96,7 +96,7 @@ onCompose f = Compose . f . getCompose type f :. g = Compose f g infixr 9 :. -newtype Const (a :: *) (b :: k) +newtype Const (a :: Type) (b :: k) = Const { getConst :: a } deriving ( Functor , Foldable @@ -134,7 +134,7 @@ instance Semigroup t => Semigroup (ElField '(s,t)) where instance (KnownSymbol s, Monoid t) => Monoid (ElField '(s,t)) where mempty = Field mempty - mappend (Field x) (Field y) = Field (mappend x y) + mappend = (<>) instance (Real t, KnownSymbol s) => Real (ElField '(s,t)) where toRational (Field x) = toRational x @@ -197,7 +197,7 @@ instance Applicative Identity where Identity f <*> Identity x = Identity (f x) instance Monad Identity where - return = Identity + return = pure Identity x >>= f = f x instance Show a => Show (Identity a) where @@ -208,7 +208,7 @@ instance Applicative Thunk where (Thunk f) <*> (Thunk x) = Thunk (f x) instance Monad Thunk where - return = Thunk + return = pure (Thunk x) >>= f = f x instance Show a => Show (Thunk a) where diff --git a/Data/Vinyl/Lens.hs b/Data/Vinyl/Lens.hs index ba3aedc..cb208a5 100644 --- a/Data/Vinyl/Lens.hs +++ b/Data/Vinyl/Lens.hs @@ -33,23 +33,20 @@ module Data.Vinyl.Lens , type (:~:) ) where -import Data.Kind (Constraint) import Data.Vinyl.Core import Data.Vinyl.Functor import Data.Vinyl.TypeLevel -#if __GLASGOW_HASKELL__ < 806 import Data.Kind -#endif -- | The presence of a field in a record is witnessed by a lens into -- its value. The fifth parameter to 'RecElem', @i@, is there to help -- the constraint solver realize that this is a decidable predicate -- with respect to the judgemental equality in @k@. class (i ~ RIndex r rs, NatToInt i) - => RecElem (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k) (rs :: [k]) (rs' :: [k]) (i :: Nat) | r r' rs i -> rs' where + => RecElem (record :: (k -> Type) -> [k] -> Type) (r :: k) (r' :: k) (rs :: [k]) (rs' :: [k]) (i :: Nat) | r r' rs i -> rs' where -- | An opportunity for instances to generate constraints based on -- the functor parameter of records passed to class methods. - type RecElemFCtx record (f :: k -> *) :: Constraint + type RecElemFCtx record (f :: k -> Type) :: Constraint type RecElemFCtx record f = () -- | We can get a lens for getting and setting the value of a field which is @@ -151,7 +148,7 @@ rlens = rlensC class is ~ RImage rs ss => RecSubset record rs ss is where -- | An opportunity for instances to generate constraints based on -- the functor parameter of records passed to class methods. - type RecSubsetFCtx record (f :: k -> *) :: Constraint + type RecSubsetFCtx record (f :: k -> Type) :: Constraint type RecSubsetFCtx record f = () -- | This is a lens into a slice of the larger record. Morally, we have: diff --git a/Data/Vinyl/Recursive.hs b/Data/Vinyl/Recursive.hs index 6e020d4..69d6c54 100644 --- a/Data/Vinyl/Recursive.hs +++ b/Data/Vinyl/Recursive.hs @@ -16,9 +16,8 @@ -- expected to have slower run times, but faster compile times than -- the definitions in "Data.Vinyl.Core". module Data.Vinyl.Recursive where -#if __GLASGOW_HASKELL__ < 806 + import Data.Kind -#endif import Data.Proxy (Proxy(..)) import Data.Vinyl.Core (rpure, RecApplicative, Rec(..), Dict(..)) import Data.Vinyl.Functor (Compose(..), (:.), Lift(..), Const(..)) @@ -147,7 +146,7 @@ reifyConstraint prx rec = -- | Build a record whose elements are derived solely from a -- constraint satisfied by each. -rpureConstrained :: forall u c (f :: u -> *) proxy ts. +rpureConstrained :: forall u c (f :: u -> Type) proxy ts. (AllConstrained c ts, RecApplicative ts) => proxy c -> (forall a. c a => f a) -> Rec f ts rpureConstrained _ f = go (rpure Proxy) @@ -157,7 +156,7 @@ rpureConstrained _ f = go (rpure Proxy) -- | Build a record whose elements are derived solely from a -- list of constraint constructors satisfied by each. -rpureConstraints :: forall cs (f :: * -> *) proxy ts. (AllAllSat cs ts, RecApplicative ts) +rpureConstraints :: forall cs (f :: Type -> Type) proxy ts. (AllAllSat cs ts, RecApplicative ts) => proxy cs -> (forall a. AllSatisfied cs a => f a) -> Rec f ts rpureConstraints _ f = go (rpure Nothing) where go :: AllAllSat cs ts' => Rec Maybe ts' -> Rec f ts' diff --git a/Data/Vinyl/SRec.hs b/Data/Vinyl/SRec.hs index 120ce1b..bf99cbb 100644 --- a/Data/Vinyl/SRec.hs +++ b/Data/Vinyl/SRec.hs @@ -64,9 +64,7 @@ module Data.Vinyl.SRec ( , peekField, pokeField ) where import Data.Coerce (coerce) -#if __GLASGOW_HASKELL__ < 806 import Data.Kind -#endif import Data.Vinyl.Core import Data.Vinyl.Functor (Lift(..), Compose(..), type (:.), ElField) import Data.Vinyl.Lens (RecElem(..), RecSubset(..), type (⊆), RecElemFCtx) @@ -132,7 +130,7 @@ mallocForeignPtrBytes = fmap ForeignPtr . newBytes -- to use it at a different type, consider using 'sget', 'sput', and -- 'slens' which work with any functor given that the necessary -- 'Storable' instances exist. -newtype SRec2 (g :: k -> *) (f :: k -> *) (ts :: [k]) = +newtype SRec2 (g :: k -> Type) (f :: k -> Type) (ts :: [k]) = SRec2 (ForeignPtr (Rec f ts)) -- | A simpler type for 'SRec2' whose 'RecElem' and 'RecSubset' @@ -230,7 +228,7 @@ mallocAndCopy src n = do dst <$ copyBytes dst' src' n -- | Set a field. -sput :: forall u (f :: u -> *) (t :: u) (ts :: [u]). +sput :: forall u (f :: u -> Type) (t :: u) (ts :: [u]). ( FieldOffset f ts t , Storable (Rec f ts) , AllConstrained (FieldOffset f ts) ts) @@ -292,12 +290,12 @@ coerceSRec1to2 = coerce coerceSRec2to1 :: SRec2 f f ts -> SRec f ts coerceSRec2to1 = coerce -instance ( i ~ RIndex (t :: (Symbol,*)) (ts :: [(Symbol,*)]) +instance ( i ~ RIndex (t :: (Symbol,Type)) (ts :: [(Symbol,Type)]) , NatToInt i , FieldOffset ElField ts t , Storable (Rec ElField ts) , AllConstrained (FieldOffset ElField ts) ts) - => RecElem SRec (t :: (Symbol,*)) t (ts :: [(Symbol,*)]) ts i where + => RecElem SRec (t :: (Symbol,Type)) t (ts :: [(Symbol,Type)]) ts i where type RecElemFCtx SRec f = f ~ ElField rlensC f = fmap coerceSRec2to1 . slens f . coerceSRec1to2 {-# INLINE rlensC #-} @@ -307,7 +305,7 @@ instance ( i ~ RIndex (t :: (Symbol,*)) (ts :: [(Symbol,*)]) {-# INLINE rputC #-} -- | Get a subset of a record's fields. -srecGetSubset :: forall u (ss :: [u]) (rs :: [u]) (f :: u -> *). +srecGetSubset :: forall u (ss :: [u]) (rs :: [u]) (f :: u -> Type). (RPureConstrained (FieldOffset f ss) rs, RPureConstrained (FieldOffset f rs) rs, RFoldMap rs, RMap rs, RApply rs, @@ -345,7 +343,7 @@ newtype TaggedIO a = TaggedIO { unTagIO :: IO () } type Poker f = Lift (->) f TaggedIO -- | Set a subset of a record's fields. -srecSetSubset :: forall u (f :: u -> *) (ss :: [u]) (rs :: [u]). +srecSetSubset :: forall u (f :: u -> Type) (ss :: [u]) (rs :: [u]). (rs ⊆ ss, RPureConstrained (FieldOffset f ss) rs, RPureConstrained (FieldOffset f rs) rs, diff --git a/Data/Vinyl/Syntax.hs b/Data/Vinyl/Syntax.hs index 2319857..bda44a6 100644 --- a/Data/Vinyl/Syntax.hs +++ b/Data/Vinyl/Syntax.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP, FlexibleInstances, InstanceSigs, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, - UndecidableInstances #-} + UndecidableInstances, FlexibleContexts #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | Concise vinyl record field lens syntax. This module exports an -- orphan instance to make working with labels a bit more powerful. It diff --git a/Data/Vinyl/TypeLevel.hs b/Data/Vinyl/TypeLevel.hs index 89e16dd..d9b7eb5 100644 --- a/Data/Vinyl/TypeLevel.hs +++ b/Data/Vinyl/TypeLevel.hs @@ -79,7 +79,7 @@ type family RDelete r rs where RDelete r (s ': rs) = s ': RDelete r rs -- | A constraint-former which applies to every field in a record. -type family RecAll (f :: u -> *) (rs :: [u]) (c :: * -> Constraint) :: Constraint where +type family RecAll (f :: u -> Type) (rs :: [u]) (c :: Type -> Constraint) :: Constraint where RecAll f '[] c = () RecAll f (r ': rs) c = (c (f r), RecAll f rs c)