diff --git a/composite-base.cabal b/composite-base.cabal --- a/composite-base.cabal +++ b/composite-base.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: composite-base -version: 0.3.1.0 +version: 0.4.0.0 synopsis: Shared utilities for composite-* packages. description: Shared helpers for the various composite packages. category: Records @@ -18,7 +18,7 @@ library hs-source-dirs: src - default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns + default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns ghc-options: -Wall -O2 build-depends: base >= 4.7 && < 5 @@ -27,12 +27,14 @@ , lens , monad-control , mtl + , profunctors , text , transformers , transformers-base , vinyl exposed-modules: Composite + Composite.CoRecord Composite.Record Composite.TH Control.Monad.Composite.Context @@ -43,7 +45,7 @@ main-is: Main.hs hs-source-dirs: test - default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns + default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators ViewPatterns ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans build-depends: base >= 4.7 && < 5 @@ -52,6 +54,7 @@ , lens , monad-control , mtl + , profunctors , text , transformers , transformers-base diff --git a/src/Composite/CoRecord.hs b/src/Composite/CoRecord.hs new file mode 100644 --- /dev/null +++ b/src/Composite/CoRecord.hs @@ -0,0 +1,216 @@ +-- |Module containing the sum formulation companion to 'Composite.Record's product formulation. Values of type @'CoRec' f rs@ represent a single value +-- @f r@ for one of the @r@s in @rs@. Heavily based on the great work by Anthony Cowley in Frames. +{-# LANGUAGE UndecidableInstances #-} -- for FoldRec +module Composite.CoRecord where + +import Prelude +import Composite.Record (AllHave, HasInstances, reifyDicts, zipRecsWith) +import Control.Lens (Prism', prism') +import Data.Functor.Identity (Identity(Identity), runIdentity) +import Data.Kind (Constraint) +import Data.Profunctor (dimap) +import Data.Proxy (Proxy(Proxy)) +import Data.Vinyl (Dict(Dict), Rec((:&), RNil), RecApplicative, RElem, recordToList, reifyConstraint, rmap, rpure) +import Data.Vinyl.Functor (Compose(Compose, getCompose), Const(Const), (:.)) +import Data.Vinyl.Lens (type (∈), rget, rput) +import Data.Vinyl.TypeLevel (RecAll, RIndex) + +-- FIXME? replace with int-index/union or at least lift ideas from there. This encoding is awkward to work with and not compositional. + +-- |@CoRef f rs@ represents a single value of type @f r@ for some @r@ in @rs@. +data CoRec :: (u -> *) -> [u] -> * where + -- |Witness that @r@ is an element of @rs@ using '∈' ('RElem' with 'RIndex') from Vinyl. + CoVal :: r ∈ rs => !(f r) -> CoRec f rs + +instance forall rs. (AllHave '[Show] rs, RecApplicative rs) => Show (CoRec Identity rs) where + show (CoVal (Identity x)) = "(CoVal " ++ show' x ++ ")" + where + shower :: Rec (Op String) rs + shower = reifyDicts (Proxy @'[Show]) (\ _ -> Op show) + show' = runOp (rget Proxy shower) + +instance forall rs. (RecAll Maybe rs Eq, RecApplicative rs) => Eq (CoRec Identity rs) where + crA == crB = and . recordToList $ zipRecsWith f (toRec crA) (fieldToRec crB) + where + f :: forall a. (Dict Eq :. Maybe) a -> Maybe a -> Const Bool a + f (Compose (Dict a)) b = Const $ a == b + toRec = reifyConstraint (Proxy @Eq) . fieldToRec + +-- |The common case of a 'CoRec' with @f ~ 'Identity'@, i.e. a regular value. +type Field = CoRec Identity + +-- |Inject a value @f r@ into a @'CoRec' f rs@ given that @r@ is one of the valid @rs@. +-- +-- Equivalent to 'CoVal' the constructor, but exists to parallel 'field'. +coRec :: r ∈ rs => f r -> CoRec f rs +coRec = CoVal + +-- |Produce a prism for the given alternative of a 'CoRec', given a proxy to identify which @r@ you meant. +coRecPrism :: (RecApplicative rs, r ∈ rs) => proxy r -> Prism' (CoRec f rs) (f r) +coRecPrism proxy = prism' CoVal (getCompose . rget proxy . coRecToRec) + +-- |Inject a value @r@ into a @'Field' rs@ given that @r@ is one of the valid @rs@. +-- +-- Equivalent to @'CoVal' . 'Identity'@. +field :: r ∈ rs => r -> Field rs +field = CoVal . Identity + +-- |Produce a prism for the given alternative of a 'Field', given a proxy to identify which @r@ you meant. +fieldPrism :: (RecApplicative rs, r ∈ rs) => proxy r -> Prism' (Field rs) r +fieldPrism proxy = coRecPrism proxy . dimap runIdentity (fmap Identity) + +-- |Apply an extraction to whatever @f r@ is contained in the given 'CoRec'. +-- +-- For example @foldCoVal getConst :: CoRec (Const a) rs -> a@. +foldCoVal :: (forall (r :: u). RElem r rs (RIndex r rs) => f r -> b) -> CoRec f rs -> b +foldCoVal f (CoVal x) = f x +{-# INLINE foldCoVal #-} + +-- |Map a @'CoRec' f@ to a @'CoRec' g@ using a natural transform from @f@ to @g@ (@forall x. f x -> g x@). +mapCoRec :: (forall x. f x -> g x) -> CoRec f rs -> CoRec g rs +mapCoRec f (CoVal x) = CoVal (f x) +{-# INLINE mapCoRec #-} + +-- |Apply some kleisli on @h@ to the @f x@ contained in a @'CoRec' f@ and yank the @h@ outside. Like 'traverse' but for 'CoRec'. +traverseCoRec :: Functor h => (forall x. f x -> h (g x)) -> CoRec f rs -> h (CoRec g rs) +traverseCoRec f (CoVal x) = CoVal <$> f x +{-# INLINE traverseCoRec #-} + +-- |Project a @'CoRec' f@ into a @'Rec' ('Maybe' ':.' f)@ where only the single @r@ held by the 'CoRec' is 'Just' in the resulting record, and all other +-- fields are 'Nothing'. +coRecToRec :: RecApplicative rs => CoRec f rs -> Rec (Maybe :. f) rs +coRecToRec (CoVal a) = rput (Compose (Just a)) (rpure (Compose Nothing)) +{-# INLINE coRecToRec #-} + +-- |Project a 'Field' into a @'Rec' 'Maybe'@ where only the single @r@ held by the 'Field' is 'Just' in the resulting record, and all other +-- fields are 'Nothing'. +fieldToRec :: RecApplicative rs => Field rs -> Rec Maybe rs +fieldToRec = rmap (fmap runIdentity . getCompose) . coRecToRec +{-# INLINE fieldToRec #-} + +-- |Typeclass which allows folding ala 'foldMap' over a 'Rec', using a 'CoRec' as the accumulator. +class FoldRec ss ts where + -- |Given some combining function, an initial value, and a record, visit each field of the record using the combining function to accumulate the + -- initial value or previous accumulation with the field of the record. + foldRec + :: (CoRec f ss -> CoRec f ss -> CoRec f ss) + -> CoRec f ss + -> Rec f ts + -> CoRec f ss + +instance FoldRec ss '[] where + foldRec _ z _ = z + {-# INLINE foldRec #-} + +instance (t ∈ ss, FoldRec ss ts) => FoldRec ss (t ': ts) where + foldRec f z (x :& xs) = foldRec f (z `f` CoVal x) xs + {-# INLINE foldRec #-} + +-- |'foldRec' for records with at least one field that doesn't require an initial value. +foldRec1 + :: FoldRec (r ': rs) rs + => (CoRec f (r ': rs) -> CoRec f (r ': rs) -> CoRec f (r ': rs)) + -> Rec f (r ': rs) + -> CoRec f (r ': rs) +foldRec1 f (x :& xs) = foldRec f (CoVal x) xs +{-# INLINE foldRec1 #-} + +-- |Given a @'Rec' ('Maybe' ':.' f) rs@, yield a @Just coRec@ for the first field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record. +firstCoRec :: FoldRec rs rs => Rec (Maybe :. f) rs -> Maybe (CoRec f rs) +firstCoRec RNil = Nothing +firstCoRec v@(x :& _) = traverseCoRec getCompose $ foldRec f (CoVal x) v + where + f c@(CoVal (Compose (Just _))) _ = c + f _ c = c +{-# INLINE firstCoRec #-} + +-- |Given a @'Rec' 'Maybe' rs@, yield a @Just field@ for the first field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record. +firstField :: FoldRec rs rs => Rec Maybe rs -> Maybe (Field rs) +firstField = firstCoRec . rmap (Compose . fmap Identity) +{-# INLINE firstField #-} + +-- |Given a @'Rec' ('Maybe' ':.' f) rs@, yield a @Just coRec@ for the last field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record. +lastCoRec :: FoldRec rs rs => Rec (Maybe :. f) rs -> Maybe (CoRec f rs) +lastCoRec RNil = Nothing +lastCoRec v@(x :& _) = traverseCoRec getCompose $ foldRec f (CoVal x) v + where + f _ c@(CoVal (Compose (Just _))) = c + f c _ = c +{-# INLINE lastCoRec #-} + +-- |Given a @'Rec' 'Maybe' rs@, yield a @Just field@ for the last field which is @Just@, or @Nothing@ if there are no @Just@ fields in the record. +lastField :: FoldRec rs rs => Rec Maybe rs -> Maybe (Field rs) +lastField = lastCoRec . rmap (Compose . fmap Identity) +{-# INLINE lastField #-} + +-- |Helper newtype containing a function @a -> b@ but with the type parameters flipped so @Op b@ has a consistent codomain for a varying domain. +newtype Op b a = Op { runOp :: a -> b } + +-- |Given a list of constraints @cs@ required to apply some function, apply the function to whatever value @r@ (not @f r@) which the 'CoRec' contains. +onCoRec + :: forall (cs :: [* -> Constraint]) (f :: * -> *) (rs :: [*]) (b :: *) (proxy :: [* -> Constraint] -> *). + (AllHave cs rs, Functor f, RecApplicative rs) + => proxy cs + -> (forall (a :: *). HasInstances a cs => a -> b) + -> CoRec f rs + -> f b +onCoRec p f (CoVal x) = go <$> x + where + go = runOp $ rget Proxy (reifyDicts p (\ _ -> Op f) :: Rec (Op b) rs) +{-# INLINE onCoRec #-} + +-- |Given a list of constraints @cs@ required to apply some function, apply the function to whatever value @r@ which the 'Field' contains. +onField + :: forall (cs :: [* -> Constraint]) (rs :: [*]) (b :: *) (proxy :: [* -> Constraint] -> *). + (AllHave cs rs, RecApplicative rs) + => proxy cs + -> (forall (a :: *). HasInstances a cs => a -> b) + -> Field rs + -> b +onField p f x = runIdentity (onCoRec p f x) +{-# INLINE onField #-} + +-- |Given some target type @r@ that's a possible value of @'Field' rs@, yield @Just@ if that is indeed the value being stored by the 'Field', or @Nothing@ if +-- not. +asA :: (r ∈ rs, RecApplicative rs) => proxy r -> Field rs -> Maybe r +asA p = rget p . fieldToRec +{-# INLINE asA #-} + +-- |An extractor function @f a -> b@ which can be passed to 'foldCoRec' to eliminate one possible alternative of a 'CoRec'. +newtype Case' f b a = Case' { unCase' :: f a -> b } + +-- |A record of @Case'@ eliminators for each @r@ in @rs@ representing the pieces of a total function from @'CoRec' f@ to @b@. +type Cases' f rs b = Rec (Case' f b) rs + +-- |Fold a @'CoRec' f@ using @Cases'@ which eliminate each possible value held by the 'CoRec', yielding the @b@ produced by whichever case matches. +foldCoRec :: RecApplicative (r ': rs) => Cases' f (r ': rs) b -> CoRec f (r ': rs) -> b +foldCoRec hs = go hs . coRecToRec + where + go :: Cases' f rs b -> Rec (Maybe :. f) rs -> b + go (Case' f :& _) (Compose (Just x) :& _) = f x + go (Case' _ :& fs) (Compose Nothing :& t) = go fs t + go RNil RNil = error "foldCoRec should be provably total, isn't" + {-# INLINE go #-} +{-# INLINE foldCoRec #-} + +-- |Fold a @'CoRec' f@ using @Cases'@ which eliminate each possible value held by the 'CoRec', yielding the @b@ produced by whichever case matches. +-- +-- Equivalent to 'foldCoRec' but with its arguments flipped so it can be written @matchCoRec coRec $ cases@. +matchCoRec :: RecApplicative (r ': rs) => CoRec f (r ': rs) -> Cases' f (r ': rs) b -> b +matchCoRec = flip foldCoRec +{-# INLINE matchCoRec #-} + +newtype Case b a = Case { unCase :: a -> b } +type Cases rs b = Rec (Case b) rs + +-- |Fold a 'Field' using 'Cases' which eliminate each possible value held by the 'Field', yielding the @b@ produced by whichever case matches. +foldField :: RecApplicative (r ': rs) => Cases (r ': rs) b -> Field (r ': rs) -> b +foldField hs = foldCoRec (rmap (Case' . (. runIdentity) . unCase) hs) +{-# INLINE foldField #-} + +-- |Fold a 'Field' using 'Cases' which eliminate each possible value held by the 'Field', yielding the @b@ produced by whichever case matches. +-- +-- Equivalent to 'foldCoRec' but with its arguments flipped so it can be written @matchCoRec coRec $ cases@. +matchField :: RecApplicative (r ': rs) => Field (r ': rs) -> Cases (r ': rs) b -> b +matchField = flip foldField +{-# INLINE matchField #-} diff --git a/src/Composite/Record.hs b/src/Composite/Record.hs --- a/src/Composite/Record.hs +++ b/src/Composite/Record.hs @@ -1,18 +1,27 @@ +{-# LANGUAGE UndecidableInstances #-} -- argh, for ReifyNames module Composite.Record ( Rec((:&), RNil), Record , pattern (:*:), pattern (:^:) , (:->)(Val, getVal), valName, valWithName , RElem, rlens, rlens' + , AllHave, HasInstances, ValuesAllHave + , zipRecsWith, reifyDicts, recordToNonEmpty + , ReifyNames(reifyNames) + , RecWithContext(rmapWithContext) ) where import Control.Lens.TH (makeWrapped) import Data.Functor.Identity (Identity(Identity)) +import Data.Kind (Constraint) +import Data.List.NonEmpty (NonEmpty((:|))) import Data.Proxy (Proxy(Proxy)) import Data.Semigroup (Semigroup) import Data.String (IsString) import Data.Text (Text, pack) -import Data.Vinyl (Rec((:&), RNil)) +import Data.Vinyl (Rec((:&), RNil), RecApplicative, recordToList, rpure) import qualified Data.Vinyl as Vinyl +import Data.Vinyl.Functor (Compose(Compose), Const(Const), (:.)) +import Data.Vinyl.Lens (type (∈)) import qualified Data.Vinyl.TypeLevel as Vinyl import Foreign.Storable (Storable) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) @@ -155,3 +164,73 @@ Vinyl.rlens proxy $ \ (fmap getVal -> fa) -> fmap Val <$> f fa {-# INLINE rlens' #-} + +-- | 'zipWith' for Rec's. +zipRecsWith :: (forall a. f a -> g a -> h a) -> Rec f as -> Rec g as -> Rec h as +zipRecsWith _ RNil _ = RNil +zipRecsWith f (r :& rs) (s :& ss) = f r s :& zipRecsWith f rs ss + +-- | Convert a provably nonempty @'Rec' ('Const' a) rs@ to a @'NonEmpty' a@. +recordToNonEmpty :: Rec (Const a) (r ': rs) -> NonEmpty a +recordToNonEmpty (Const a :& rs) = a :| recordToList rs + +-- |Type function which produces a constraint on @a@ for each constraint in @cs@. +-- +-- For example, @HasInstances Int '[Eq, Ord]@ is equivalent to @(Eq Int, Ord Int)@. +type family HasInstances (a :: u) (cs :: [u -> Constraint]) :: Constraint where + HasInstances a '[] = () + HasInstances a (c ': cs) = (c a, HasInstances a cs) + +-- |Type function which produces the cross product of constraints @cs@ and types @as@. +-- +-- For example, @AllHave '[Eq, Ord] '[Int, Text]@ is equivalent to @(Eq Int, Ord Int, Eq Text, Ord Text)@ +type family AllHave (cs :: [u -> Constraint]) (as :: [u]) :: Constraint where + AllHave cs '[] = () + AllHave cs (a ': as) = (HasInstances a cs, AllHave cs as) + +-- |Type function which produces the cross product of constraints @cs@ and the values carried in a record @rs@. +-- +-- For example, @ValuesAllHave '[Eq, Ord] '["foo" :-> Int, "bar" :-> Text]@ is equivalent to @(Eq Int, Ord Int, Eq Text, Ord Text)@ +type family ValuesAllHave (cs :: [u -> Constraint]) (as :: [u]) :: Constraint where + ValuesAllHave cs '[] = () + ValuesAllHave cs (s :-> a ': as) = (HasInstances a cs, ValuesAllHave cs as) + + +-- |Given a list of constraints @cs@, apply some function for each @r@ in the target record type @rs@ with proof that those constraints hold for @r@, +-- generating a record with the result of each application. +reifyDicts + :: forall (cs :: [u -> Constraint]) (f :: u -> *) (rs :: [u]) (proxy :: [u -> Constraint] -> *). + (AllHave cs rs, RecApplicative rs) + => proxy cs + -> (forall proxy' (a :: u). HasInstances a cs => proxy' a -> f a) + -> Rec f rs +reifyDicts _ f = go (rpure (Const ())) + where + go :: forall (rs' :: [u]). AllHave cs rs' => Rec (Const ()) rs' -> Rec f rs' + go RNil = RNil + go ((_ :: Const () a) :& xs) = f (Proxy @a) :& go xs +{-# INLINE reifyDicts #-} + +-- |Class which reifies the symbols of a record composed of ':->' fields as 'Text'. +class ReifyNames (rs :: [*]) where + -- |Given a @'Rec' f rs@ where each @r@ in @rs@ is of the form @s ':->' a@, make a record which adds the 'Text' for each @s@. + reifyNames :: Rec f rs -> Rec ((,) Text :. f) rs + +instance ReifyNames '[] where + reifyNames _ = RNil + +instance forall (s :: Symbol) a (rs :: [*]). (KnownSymbol s, ReifyNames rs) => ReifyNames (s :-> a ': rs) where + reifyNames (fa :& rs) = Compose ((,) (pack $ symbolVal (Proxy @s)) fa) :& reifyNames rs + +-- |Class with 'Data.Vinyl.rmap' but which gives the natural transformation evidence that the value its working over is contained within the overall record @ss@. +class RecWithContext (ss :: [*]) (ts :: [*]) where + -- |Apply a natural transformation from @f@ to @g@ to each field of the given record, except that the natural transformation can be mildly unnatural by having + -- evidence that @r@ is in @ss@. + rmapWithContext :: proxy ss -> (forall r. r ∈ ss => f r -> g r) -> Rec f ts -> Rec g ts + +instance RecWithContext ss '[] where + rmapWithContext _ _ _ = RNil + +instance forall r (ss :: [*]) (ts :: [*]). (r ∈ ss, RecWithContext ss ts) => RecWithContext ss (r ': ts) where + rmapWithContext proxy n (r :& rs) = n r :& rmapWithContext proxy n rs + diff --git a/src/Control/Monad/Composite/Context.hs b/src/Control/Monad/Composite/Context.hs --- a/src/Control/Monad/Composite/Context.hs +++ b/src/Control/Monad/Composite/Context.hs @@ -134,7 +134,7 @@ callCC f = ContextT $ \ r -> callCC $ \ c -> runContextT (f (ContextT . const . c)) r instance MonadThrow m => MonadThrow (ContextT c m) where - throwM e = ContextT $ \ r -> throwM e + throwM e = ContextT $ \ _ -> throwM e instance MonadCatch m => MonadCatch (ContextT c m) where catch m h = ContextT $ \ r -> catch (runContextT m r) (\ e -> runContextT (h e) r)