composite-base 0.3.1.0 → 0.4.0.0

raw patch · 4 files changed

+303/−5 lines, 4 filesdep +profunctorsPVP ok

version bump matches the API change (PVP)

Dependencies added: profunctors

API changes (from Hackage documentation)

Files

• composite-base.cabal +6/−3
• src/Composite/CoRecord.hs +216/−0
• src/Composite/Record.hs +80/−1
• src/Control/Monad/Composite/Context.hs +1/−1

@@ -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

@@ -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 #-}

@@ -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+

@@ -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)