composite-base 0.7.6.0 → 0.8.3.0
raw patch · 7 files changed
Files
- LICENSE +30/−0
- composite-base.cabal +13/−18
- src/Composite/CoRecord.hs +87/−7
- src/Composite/Record.hs +23/−18
- src/Composite/TH.hs +19/−4
- src/Control/Monad/Composite/Context.hs +3/−2
- test/RecordSpec.hs +5/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017 Confer Health, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Confer Health nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
composite-base.cabal view
@@ -1,21 +1,16 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.5.------ see: https://github.com/sol/hpack------ hash: 1bd1f66bd3d38d9ed108f5b7c2e4d437903998f82224fddeefae706b03de417d- name: composite-base-version: 0.7.6.0+version: 0.8.3.0 synopsis: Shared utilities for composite-* packages. description: Shared helpers for the various composite packages. category: Records-homepage: https://github.com/ConferOpenSource/composite#readme+homepage: https://github.com/composite-hs/composite-base#readme author: Confer Health, Inc. maintainer: oss@vitalbio.com copyright: 2017 Confer Health, Inc., 2020-2021 Vital Biosciences license: BSD3+license-file: LICENSE build-type: Simple library@@ -58,13 +53,13 @@ base >=4.12 && <5 , deepseq ==1.4.* , exceptions >=0.8.3 && <0.11- , lens >=4.15.4 && <5.2+ , lens >=4.15.4 && <5.3 , monad-control >=1.0.2.2 && <1.1- , mtl >=2.2.1 && <2.3+ , mtl >=2.2.1 && <2.4 , profunctors >=5.2.1 && <5.7- , template-haskell >=2.11.1.0 && <2.19- , text >=1.2.2.2 && <1.3- , transformers >=0.5.2.0 && <0.6+ , template-haskell >=2.11.1.0 && <2.22+ , text >=1.2.2.2 && <2.1+ , transformers >=0.5.2.0 && <0.7 , transformers-base >=0.4.4 && <0.5 , unliftio-core >=0.1.0.0 && <0.3.0.0 , vinyl >=0.5.3 && <0.15@@ -111,13 +106,13 @@ , deepseq ==1.4.* , exceptions >=0.8.3 && <0.11 , hspec- , lens >=4.15.4 && <5.2+ , lens >=4.15.4 && <5.3 , monad-control >=1.0.2.2 && <1.1- , mtl >=2.2.1 && <2.3+ , mtl >=2.2.1 && <2.4 , profunctors >=5.2.1 && <5.7- , template-haskell >=2.11.1.0 && <2.19- , text >=1.2.2.2 && <1.3- , transformers >=0.5.2.0 && <0.6+ , template-haskell >=2.11.1.0 && <2.21+ , text >=1.2.2.2 && <2.1+ , transformers >=0.5.2.0 && <0.7 , transformers-base >=0.4.4 && <0.5 , unliftio-core >=0.1.0.0 && <0.3.0.0 , vinyl >=0.5.3 && <0.15
src/Composite/CoRecord.hs view
@@ -5,21 +5,26 @@ import Prelude import Composite.Record (AllHave, HasInstances, (:->)(getVal, Val), reifyDicts, reifyVal, val, zipRecsWith)-import Control.Lens (Prism', prism')+import Control.DeepSeq (NFData, rnf)+import Control.Lens (Prism', Wrapped, Unwrapped, prism', review, view, _Wrapped')+import Control.Monad.Except (ExceptT, throwError, withExceptT)+import Data.Functor.Contravariant (Contravariant(contramap)) import Data.Functor.Identity (Identity(Identity), runIdentity)-import Data.Kind (Constraint)+import Data.Kind (Constraint, Type) import Data.Maybe (fromMaybe) import Data.Profunctor (dimap) import Data.Proxy (Proxy(Proxy))+import Data.Text (Text, pack) import Data.Vinyl.Core (Dict(Dict), Rec((:&), RNil), RMap, RecApplicative, RecordToList, ReifyConstraint, recordToList, reifyConstraint, rmap, rpure) import Data.Vinyl.Functor (Compose(Compose, getCompose), Const(Const), (:.)) import Data.Vinyl.Lens (RElem, type (∈), type (⊆), rget, rput, rreplace) import Data.Vinyl.TypeLevel (RecAll, RIndex)+import GHC.TypeLits (KnownSymbol, symbolVal) -- 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+data CoRec :: (u -> Type) -> [u] -> Type where -- |Witness that @r@ is an element of @rs@ using '∈' ('RElem' with 'RIndex') from Vinyl. CoVal :: r ∈ rs => !(f r) -> CoRec f rs @@ -37,6 +42,13 @@ f (Compose (Dict a)) b = Const $ a == b toRec = reifyConstraint . fieldToRec +instance forall rs. (AllHave '[NFData] rs, RecApplicative rs) => NFData (CoRec Identity rs) where+ rnf (CoVal (Identity x)) = rnf' x+ where+ rnfer :: Rec (Op ()) rs+ rnfer = reifyDicts (Proxy @'[NFData]) (\ _ -> Op rnf)+ rnf' = runOp (rget rnfer)+ -- |The common case of a 'CoRec' with @f ~ 'Identity'@, i.e. a regular value. type Field = CoRec Identity @@ -159,10 +171,10 @@ -- |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] -> *).+ :: forall (cs :: [Type -> Constraint]) (f :: Type -> Type) (rs :: [Type]) (b :: Type) (proxy :: [Type -> Constraint] -> Type). (AllHave cs rs, Functor f, RecApplicative rs) => proxy cs- -> (forall (a :: *). HasInstances a cs => a -> b)+ -> (forall (a :: Type). HasInstances a cs => a -> b) -> CoRec f rs -> f b onCoRec p f (CoVal x) = go <$> x@@ -172,10 +184,10 @@ -- |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] -> *).+ :: forall (cs :: [Type -> Constraint]) (rs :: [Type]) (b :: Type) (proxy :: [Type -> Constraint] -> Type). (AllHave cs rs, RecApplicative rs) => proxy cs- -> (forall (a :: *). HasInstances a cs => a -> b)+ -> (forall (a :: Type). HasInstances a cs => a -> b) -> Field rs -> b onField p f x = runIdentity (onCoRec p f x)@@ -190,6 +202,9 @@ -- |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 } +instance Functor f => Contravariant (Case' f b) where+ contramap f (Case' r) = Case' $ \x -> r (fmap f x) + -- |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 @@ -212,6 +227,10 @@ {-# INLINE matchCoRec #-} newtype Case b a = Case { unCase :: a -> b }++instance Contravariant (Case b) where+ contramap f (Case r) = Case $ r . f+ 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.@@ -237,3 +256,64 @@ widenField r = fromMaybe (error "widenField should be provably total, isn't") $ firstField (rreplace (fieldToRec r) (rpure Nothing))++-- |Constraint showing that @rs ⊆ ss@ and giving enough power to widen a @'CoRec' f rs@ to @'CoRec' f ss@.+type WiderCoRec rs ss = (FoldRec ss ss, RecApplicative rs, RecApplicative ss, rs ⊆ ss)++-- |Constraint on a pair of types @r@ and @s@ which are 'Wrapped' around @'CoRec' f rs@ and @'CoRec' f ss@ respectively and observes that those types can be unwrapped and the former can be widened to the latter.+type WrappedWiderCoRec f r rs s ss = (Wrapped r, Unwrapped r ~ CoRec f rs, Wrapped s, Unwrapped s ~ CoRec f ss, WiderCoRec rs ss)++-- |'WrappedWiderCoRec' specialized to 'CoRec' 'Identity', i.e. 'Field'.+type WrappedWiderField r rs s ss = WrappedWiderCoRec Identity r rs s ss++-- |Widen a @'CoRec' f rs@ wrapped in @r@ to a @'CoRec' f ss@ wrapped in @s@.+widenWrappedCoRec :: WrappedWiderCoRec f r rs s ss => r -> s+widenWrappedCoRec = review _Wrapped' . widenCoRec . view _Wrapped'++-- |Widen a @'Field' rs@ wrapped in @r@ to a @'Field' ss@ wrapped in @s@.+widenWrappedField :: WrappedWiderField r rs s ss => r -> s+widenWrappedField = review _Wrapped' . widenCoRec . view _Wrapped'++-- |Widen a wrapped 'CoRec' using 'widenWrappedCoRec' and then throw it as an 'ExceptT' error, as a convenience when using 'CoRec' / 'Field' for building up error types by set union.+throwWidened :: (Monad m, WrappedWiderCoRec f e er e' er') => e -> ExceptT e' m a+throwWidened = throwError . widenWrappedCoRec++-- |Catch a wrapped 'CoRec' thrown by an 'ExceptT' and widen it using 'widenWrappedCoRec' then rethrow it, as a convenience when using 'CoRec' / 'Field' for building up error types by set union.+rethrowWidened :: (Functor m, WrappedWiderCoRec f e er e' er') => ExceptT e m a -> ExceptT e' m a+rethrowWidened = withExceptT widenWrappedCoRec++-- |Specialized type of 'Case' for 'Val', with the type parameters in a convenient order for type application, e.g.:+--+-- @+-- valCase @"foo" (\ a -> ...)+-- :& valCase @"bar" (\ b -> ...)+-- :& RNil+-- @+valCase :: forall s a b. (a -> b) -> Case b (s :-> a)+valCase f = Case $ \(Val a) -> f a++-- |Specialized type of 'Case'' for 'Val', with the type parameters in a convenient order for type application, e.g.:+--+-- @+-- valCase' @"foo" (\ fa -> ...)+-- :& valCase' @"bar" (\ fb -> ...)+-- :& RNil+-- @+valCase' :: forall s f a b. Functor f => (f a -> b) -> Case' f b (s :-> a)+valCase' f = Case' $ \fva -> f (fmap getVal fva)++-- |Make a 'Case' which yields the symbol text for a field @s :-> ()@. E.g.:+--+-- @+-- keywordCase @"foo" (Identity (Val ())) == "foo"+-- @+keywordCase :: KnownSymbol s => Case Text (s :-> ())+keywordCase = keywordCase' id++-- |Make a 'Case'' which yields the symbol text for a field @s :-> ()@ as projected through the given function. E.g.:+--+-- @+-- keywordCase @"foo" (<> "bar") (Identity (Val ())) == "foobar"+-- @+keywordCase' :: KnownSymbol s => (Text -> a) -> Case a (s :-> ())+keywordCase' f = Case $ \(Val () :: s :-> ()) -> f (pack (symbolVal (Proxy @s)))
src/Composite/Record.hs view
@@ -10,21 +10,23 @@ , ReifyNames(reifyNames) , RecWithContext(rmapWithContext) , RDelete, RDeletable, rdelete+ , rwiden+ , _SingleVal ) where import Control.DeepSeq(NFData(rnf)) import Control.Lens (Iso, iso) import Control.Lens.TH (makeWrapped)-import Data.Functor.Identity (Identity(Identity))+import Data.Functor.Identity (Identity(Identity), runIdentity) import Data.Functor.Contravariant (Contravariant(contramap))-import Data.Kind (Constraint)+import Data.Kind (Constraint, Type) import Data.List.NonEmpty (NonEmpty((:|))) import Data.Proxy (Proxy(Proxy)) import Data.String (IsString) import Data.Text (Text, pack)-import Data.Vinyl (Rec((:&), RNil), RecApplicative, rcast, recordToList, rpure)+import Data.Vinyl (Rec((:&), RNil), RecApplicative, RMap, rcast, rdowncast, recordToList, rmap, rpure) import qualified Data.Vinyl as Vinyl-import Data.Vinyl.Functor (Compose(Compose), Const(Const), (:.))+import Data.Vinyl.Functor (Compose(Compose, getCompose), Const(Const), (:.)) import Data.Vinyl.Lens (type (∈), type (⊆)) import qualified Data.Vinyl.TypeLevel as Vinyl import Data.Vinyl.XRec(IsoHKD(HKD, toHKD, unHKD))@@ -80,20 +82,12 @@ traverse k (Val a) = Val <$> k a {-# INLINE traverse #-} instance Monad ((:->) s) where- return = Val- {-# INLINE return #-} Val a >>= k = k a {-# INLINE (>>=) #-} instance NFData a => NFData (s :-> a) where rnf (Val x) = rnf x -instance NFData (Record '[]) where- rnf RNil = ()--instance (NFData x, NFData (Record xs)) => NFData (Record (x : xs)) where- rnf (x :& xs) = rnf x `seq` rnf xs- instance forall (s :: Symbol) a. (KnownSymbol s, Show a) => Show (s :-> a) where showsPrec p (Val a) = ((symbolVal (Proxy :: Proxy s) ++ " :-> ") ++) . showsPrec p a @@ -299,14 +293,14 @@ -- |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 u. forall (cs :: [u -> Constraint]) (f :: u -> *) (rs :: [u]) (proxy :: [u -> Constraint] -> *).+ :: forall u. forall (cs :: [u -> Constraint]) (f :: u -> Type) (rs :: [u]) (proxy :: [u -> Constraint] -> Type). (AllHave cs rs, RecApplicative rs) => proxy cs -> (forall proxy' (a :: u). HasInstances a cs => proxy' a -> f a) -> Rec f rs reifyDicts x f = go x (rpure (Const ())) f where- go :: forall (f :: u -> *) (cs :: [u -> Constraint]) (rs' :: [u]) (proxy :: [u -> Constraint] -> *). AllHave cs rs'+ go :: forall (f :: u -> Type) (cs :: [u -> Constraint]) (rs' :: [u]) (proxy :: [u -> Constraint] -> Type). AllHave cs rs' => proxy cs -> Rec (Const ()) rs' -> (forall proxy' (a :: u). HasInstances a cs => proxy' a -> f a)@@ -316,18 +310,18 @@ {-# INLINE reifyDicts #-} -- |Class which reifies the symbols of a record composed of ':->' fields as 'Text'.-class ReifyNames (rs :: [*]) where+class ReifyNames (rs :: [Type]) 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+instance forall (s :: Symbol) a (rs :: [Type]). (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+class RecWithContext (ss :: [Type]) (ts :: [Type]) 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@@ -335,7 +329,7 @@ instance RecWithContext ss '[] where rmapWithContext _ _ _ = RNil -instance forall r (ss :: [*]) (ts :: [*]). (r ∈ ss, RecWithContext ss ts) => RecWithContext ss (r ': ts) where+instance forall r (ss :: [Type]) (ts :: [Type]). (r ∈ ss, RecWithContext ss ts) => RecWithContext ss (r ': ts) where rmapWithContext proxy n (r :& rs) = n r :& rmapWithContext proxy n rs -- |Type function which removes the first element @r@ from a list @rs@, and doesn't expand if @r@ is not present in @rs@.@@ -349,3 +343,14 @@ -- |Remove an element @r@ from a @'Rec' f rs@. Note this is just a type constrained 'rcast'. rdelete :: RDeletable r rs => proxy r -> Rec f rs -> Rec f (RDelete r rs) rdelete _ = rcast++-- |Widen a record from @'Record' rs@ to @'Rec' 'Maybe' ss@. Note this is just a type constrainted 'rdowncast'.+rwiden :: (RecApplicative ss, RMap rs, RMap ss, rs ⊆ ss) => Record rs -> Rec Maybe ss+rwiden = rmap (fmap runIdentity . getCompose) . rdowncast++-- |'Iso' which observes that a record with a single field @s@ with value @a@ is isomorphic to the value alone.+_SingleVal :: forall s a b. Iso (Record '[s :-> a]) (Record '[s :-> b]) a b+_SingleVal =+ let toA :: Record '[s :-> a] -> a = getVal . runIdentity . Vinyl.rget @(s :-> a)+ fromA x = Identity (Val x) :& RNil+ in iso toA fromA
src/Composite/TH.hs view
@@ -22,6 +22,9 @@ #if MIN_VERSION_template_haskell(2,17,0) , Specificity(SpecifiedSpec) #endif+#if MIN_VERSION_template_haskell(2,21,0)+ , BndrVis+#endif ) import Language.Haskell.TH.Lens (_TySynD) @@ -146,11 +149,19 @@ withOpticsAndProxies = withBoilerplate True True #if MIN_VERSION_template_haskell(2,17,0)+#if MIN_VERSION_template_haskell(2,21,0)+tyUnitToSpec :: Specificity -> TyVarBndr BndrVis -> TyVarBndr Specificity+#else tyUnitToSpec :: Specificity -> TyVarBndr () -> TyVarBndr Specificity-tyUnitToSpec x (PlainTV n ()) = PlainTV n x-tyUnitToSpec x (KindedTV n () k) = KindedTV n x k+#endif+tyUnitToSpec x (PlainTV n _) = PlainTV n x+tyUnitToSpec x (KindedTV n _ k) = KindedTV n x k +#if MIN_VERSION_template_haskell(2,21,0)+fieldDecUnitToSpec :: Specificity -> FieldDec BndrVis -> FieldDec Specificity+#else fieldDecUnitToSpec :: Specificity -> FieldDec () -> FieldDec Specificity+#endif fieldDecUnitToSpec x (FieldDec n b t v) = FieldDec n (map (tyUnitToSpec x) b) t v data FieldDec a = FieldDec@@ -186,7 +197,9 @@ #endif pure $ decs <> concat proxyDecs <> concat lensDecs <> concat prismDecs -#if MIN_VERSION_template_haskell(2,17,0)+#if MIN_VERSION_template_haskell(2,21,0)+fieldDecMay :: (Name, [TyVarBndr BndrVis], Type) -> Maybe (FieldDec BndrVis)+#elif MIN_VERSION_template_haskell(2,17,0) fieldDecMay :: (Name, [TyVarBndr ()], Type) -> Maybe (FieldDec ()) #else fieldDecMay :: (Name, [TyVarBndr], Type) -> Maybe FieldDec@@ -210,7 +223,9 @@ prismNameFor = mkName . ("_" ++) . nameBase proxyNameFor = mkName . (++ "_") . over _head toLower . nameBase -#if MIN_VERSION_template_haskell(2,17,0)+#if MIN_VERSION_template_haskell(2,21,0)+proxyDecFor :: FieldDec BndrVis -> Q [Dec]+#elif MIN_VERSION_template_haskell(2,17,0) proxyDecFor :: FieldDec () -> Q [Dec] #else proxyDecFor :: FieldDec -> Q [Dec]
src/Control/Monad/Composite/Context.hs view
@@ -46,6 +46,7 @@ import qualified Control.Monad.Writer.Lazy as Lazy import qualified Control.Monad.Writer.Strict as Strict import Control.Monad.Writer.Class (MonadWriter(writer, tell, listen, pass))+import Data.Kind (Type) import Control.Monad.IO.Unlift ( MonadUnliftIO@@ -59,7 +60,7 @@ -- |Class of monad (stacks) which have context reading functionality baked in. Similar to 'Control.Monad.Reader.MonadReader' but can coexist with a -- another monad that provides 'Control.Monad.Reader.MonadReader' and requires the context to be a record.-class Monad m => MonadContext (c :: [*]) m | m -> c where+class Monad m => MonadContext (c :: [Type]) m | m -> c where -- |Fetch the context record from the environment. askContext :: m (Record c) @@ -123,7 +124,7 @@ askField l = asksContext $ view l -- |Monad transformer which adds an implicit environment which is a record. Isomorphic to @ReaderT (Record c) m@.-newtype ContextT (c :: [*]) (m :: (* -> *)) a = ContextT { runContextT :: Record c -> m a }+newtype ContextT (c :: [Type]) (m :: (Type -> Type)) a = ContextT { runContextT :: Record c -> m a } -- |Run some action in a given context, equivalent to 'runContextT' but with the arguments flipped. runInContext :: Record c -> ContextT c m a -> m a
test/RecordSpec.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 902+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+#endif+ module RecordSpec where import Composite.Record