composite-base 0.2.0.0 → 0.3.0.0

raw patch · 8 files changed

+242/−89 lines, 8 filesdep +monad-controldep +mtldep +transformersdep −Framesdep −basic-preludePVP ok

version bump matches the API change (PVP)

Dependencies added: monad-control, mtl, transformers, transformers-base

Dependencies removed: Frames, basic-prelude

API changes (from Hackage documentation)

Files

• composite-base.cabal +12/−8
• src/Composite.hs +1/−3
• src/Composite/Base.hs +0/−26
• src/Composite/Record.hs +84/−38
• src/Composite/TH.hs +2/−2
• src/Control/Monad/Composite/Context.hs +133/−0
• test/Main.hs +0/−1
• test/RecordSpec.hs +10/−11

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           composite-base-version:        0.2.0.0+version:        0.3.0.0 synopsis:       Shared utilities for composite-* packages. description:    Shared helpers for the various composite packages. category:       Records@@ -18,21 +18,23 @@ library   hs-source-dirs:       src-  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude OverloadedStrings PatternSynonyms PolyKinds ScopedTypeVariables StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns   ghc-options: -Wall -O2   build-depends:       base >= 4.7 && < 5-    , Frames-    , basic-prelude     , template-haskell     , lens+    , monad-control+    , mtl     , text+    , transformers+    , transformers-base     , vinyl   exposed-modules:       Composite-      Composite.Base       Composite.Record       Composite.TH+      Control.Monad.Composite.Context   default-language: Haskell2010  test-suite composite-base-test@@ -40,15 +42,17 @@   main-is: Main.hs   hs-source-dirs:       test-  default-extensions: DataKinds FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NoImplicitPrelude OverloadedStrings PatternSynonyms PolyKinds ScopedTypeVariables StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns+  default-extensions: ConstraintKinds DataKinds FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeFamilies TypeOperators ViewPatterns   ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans   build-depends:       base >= 4.7 && < 5-    , Frames-    , basic-prelude     , template-haskell     , lens+    , monad-control+    , mtl     , text+    , transformers+    , transformers-base     , vinyl     , QuickCheck     , composite-base

@@ -1,8 +1,6 @@ module Composite-  ( module Composite.Base-  , module Composite.Record+  ( module Composite.Record   ) where -import Composite.Base import Composite.Record 

@@ -1,26 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Composite.Base (NamedField(..), fieldAsPair) where--import BasicPrelude-import Control.Lens (Wrapped(type Unwrapped, _Wrapped'), Rewrapped, _Wrapped, iso, view)-import Data.Proxy (Proxy(Proxy))-import Data.Text (pack)-import Frames ((:->)(Col, getCol))-import GHC.TypeLits (KnownSymbol, symbolVal)---- |Class of types which represent fields which can be named statically (i.e. via their type only) and contain some value.-class (Wrapped f, Rewrapped f f) => NamedField f where-  -- |Reflect the name of the field as @Text@ given some proxy representing the type.-  fieldName :: proxy f -> Text---- |Extract the value and reflect the name of some named field.-fieldAsPair :: forall f. NamedField f => f -> (Text, Unwrapped f)-fieldAsPair = (fieldName (Proxy :: Proxy f),) . view _Wrapped--instance Wrapped (s :-> a) where-  type Unwrapped (s :-> a) = a-  _Wrapped' = iso getCol Col--instance (t ~ (s :-> b)) => Rewrapped (s :-> a) t-instance KnownSymbol s => NamedField (s :-> a) where-  fieldName _ = pack $ symbolVal (Proxy :: Proxy s)

@@ -1,43 +1,90 @@ module Composite.Record-  ( Rec, Record, Identity(Identity)-  , pattern (:*:), pattern (:^:), pattern Nil, pattern Val-  , (:->)(Col, getCol)-  , rlens, rlens'+  ( Rec((:&), RNil), Record+  , pattern (:*:), pattern (:^:)+  , (:->)(Val, getVal), valName, valWithName+  , RElem, rlens, rlens'   ) where -import BasicPrelude+import Control.Lens.TH (makeWrapped)+import Data.Functor.Identity (Identity(Identity))+import Data.Proxy (Proxy(Proxy))+import Data.Semigroup (Semigroup)+import Data.String (IsString)+import Data.Text (Text, pack) import Data.Vinyl (Rec((:&), RNil)) import qualified Data.Vinyl as Vinyl-import Data.Vinyl.Functor (Identity(Identity))-import Data.Vinyl.Lens (RElem)-import Data.Vinyl.TypeLevel (RIndex)-import Frames (Record, (:->)(Col, getCol))-import qualified Frames+import qualified Data.Vinyl.TypeLevel as Vinyl+import Foreign.Storable (Storable)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) --- |Pattern synonym equivalent to the empty record 'RNil'.------ This pattern is bidirectional meaning you can use it either a pattern or as a constructor, e.g.------ @---   let Nil = Nil :: 'Record' '[]--- @------ is valid.-pattern Nil :: Vinyl.Rec f '[]-pattern Nil = RNil+type Record = Rec Identity+type RElem r rs = Vinyl.RElem r rs (Vinyl.RIndex r rs) +newtype (:->) (s :: Symbol) a = Val { getVal :: a }++makeWrapped ''(:->)++deriving instance Bounded    a => Bounded    (s :-> a)+deriving instance Enum       a => Enum       (s :-> a)+deriving instance Eq         a => Eq         (s :-> a)+deriving instance Floating   a => Floating   (s :-> a)+deriving instance Fractional a => Fractional (s :-> a)+deriving instance Integral   a => Integral   (s :-> a)+deriving instance IsString   a => IsString   (s :-> a)+deriving instance Monoid     a => Monoid     (s :-> a)+deriving instance Num        a => Num        (s :-> a)+deriving instance Ord        a => Ord        (s :-> a)+deriving instance Real       a => Real       (s :-> a)+deriving instance RealFloat  a => RealFloat  (s :-> a)+deriving instance RealFrac   a => RealFrac   (s :-> a)+deriving instance Semigroup  a => Semigroup  (s :-> a)+deriving instance Storable   a => Storable   (s :-> a)++instance Functor ((:->) s) where+  fmap f = Val . f . getVal+  {-# INLINE fmap #-}+instance Applicative ((:->) s) where+  pure = Val+  {-# INLINE pure #-}+  Val f <*> Val a = Val (f a)+  {-# INLINE (<*>) #-}+instance Foldable ((:->) s) where+  foldr f z (Val a) = f a z+  {-# INLINE foldr #-}+instance Traversable ((:->) s) where+  traverse k (Val a) = Val <$> k a+  {-# INLINE traverse #-}+instance Monad ((:->) s) where+  return = Val+  {-# INLINE return #-}+  Val a >>= k = k a+  {-# INLINE (>>=) #-}++instance forall (s :: Symbol) a. (KnownSymbol s, Show a) => Show (s :-> a) where+  showsPrec p (Val a) = ((symbolVal (Proxy :: Proxy s) ++ " :-> ") ++) . showsPrec p a++-- |Reflect the type level name of a named value @s :-> a@ to a @Text@. For example, given @"foo" :-> Int@, yields @"foo" :: Text@+valName :: forall s a. KnownSymbol s => s :-> a -> Text+valName _ = pack (symbolVal (Proxy :: Proxy s))+{-# INLINE valName #-}++-- |Extract the value and reflect the name of a named value.+valWithName :: forall s a. KnownSymbol s => s :-> a -> (Text, a)+valWithName v = (valName v, getVal v)+{-# INLINE valWithName #-}+ -- |Bidirectional pattern matching the first field of a record using ':->' values and the 'Identity' functor. -- -- This pattern is bidirectional meaning you can use it either as a pattern or a constructor, e.g. -- -- @---   let rec = 123 :*: Just "foo" :*: Nil---       foo :*: bar :*: Nil = rec+--   let rec = 123 :*: Just "foo" :*: RNil+--       foo :*: bar :*: RNil = rec -- @ -- -- Mnemonic: @*@ for products. pattern (:*:) :: () => () => a -> Rec Identity rs -> Rec Identity (s :-> a ': rs)-pattern (:*:) a rs = Identity (Col a) :& rs+pattern (:*:) a rs = Identity (Val a) :& rs infixr 5 :*:  -- |Bidirectional pattern matching the first field of a record using ':->' values and any functor.@@ -45,20 +92,16 @@ -- This pattern is bidirectional meaning you can use it either as a pattern or a constructor, e.g. -- -- @---   let rec = Just 123 :^: Just "foo" :^: Nil---       Just foo :^: Just bar :^: Nil = rec+--   let rec = Just 123 :^: Just "foo" :^: RNil+--       Just foo :^: Just bar :^: RNil = rec -- @ -- -- Mnemonic: @^@ for products (record) of products (functor). pattern (:^:) :: Functor f => () => f a -> Rec f rs -> Rec f (s :-> a ': rs)-pattern (:^:) fa rs <- (map getCol -> fa) :& rs where-  (:^:) fa rs = map Col fa :& rs+pattern (:^:) fa rs <- (fmap getVal -> fa) :& rs where+  (:^:) fa rs = fmap Val fa :& rs infixr 5 :^: --- |Bidirectional pattern unwrapping @Identity (s :-> a)@ to @a@.-pattern Val :: a -> Identity (s :-> a)-pattern Val a = Identity (Col a)- -- |Lens to a particular field of a record using the 'Identity' functor. -- -- For example, given:@@ -80,8 +123,11 @@ --   set  (rlens fBar_) "goodbye!"    rec == 123 :*: "goodbye!" :*: Nil --   over (rlens fBar_) (map toUpper) rec == 123 :*: "HELLO!"   :*: Nil -- @-rlens :: (Functor g, RElem (s :-> a) rs (RIndex (s :-> a) rs), Functor g) => proxy (s :-> a) -> (a -> g a) -> Rec Identity rs -> g (Rec Identity rs)-rlens = Frames.rlens+rlens :: (Functor g, RElem (s :-> a) rs, Functor g) => proxy (s :-> a) -> (a -> g a) -> Rec Identity rs -> g (Rec Identity rs)+rlens proxy f =+  Vinyl.rlens proxy $ \ (Identity (Val a)) ->+    Identity . Val <$> f a+{-# INLINE rlens #-}  -- |Lens to a particular field of a record using any functor. --@@ -104,8 +150,8 @@ --   set  (rlens' fBar_) Nothing              rec == Just 123 :^: Nothing       :^: Nil --   over (rlens' fBar_) (fmap (map toUpper)) rec == Just 123 :^: Just "HELLO!" :^: Nil -- @-rlens' :: (Functor f, Functor g, RElem (s :-> a) rs (RIndex (s :-> a) rs), Functor g) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs)+rlens' :: (Functor f, Functor g, RElem (s :-> a) rs, Functor g) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs) rlens' proxy f =-  Vinyl.rlens proxy $ \ (map getCol -> fa) ->-    map Col <$> f fa-+  Vinyl.rlens proxy $ \ (fmap getVal -> fa) ->+    fmap Val <$> f fa+{-# INLINE rlens' #-}

@@ -1,12 +1,12 @@ module Composite.TH where -import BasicPrelude+import Composite.Record (Record, rlens) import Control.Lens (_1, _head, each, over, toListOf) import Data.Char (toLower)+import Data.Monoid ((<>)) import Data.Proxy (Proxy(Proxy)) import Data.Vinyl.Lens (RElem) import Data.Vinyl.TypeLevel (RIndex)-import Frames (Record, rlens) import Language.Haskell.TH (Q, Body(NormalB), Dec(SigD, ValD), Exp(VarE), Name, Pat(VarP), Type(AppT, ConT), TyVarBndr, mkName, nameBase) import Language.Haskell.TH.Lens (_TySynD) 

@@ -0,0 +1,133 @@+{-# LANGUAGE UndecidableInstances #-}+-- Required to make passthrough instances for MonadContext for things like ReaderT work as they do not satisfy the functional dependency | m -> c++-- |Module with a `ReaderT` style monad specialized to holding a record.+module Control.Monad.Composite.Context+  ( ContextT(ContextT, runContextT), withContext, mapContextT+  , MonadContext(askContext, localContext), asksContext, askField+  ) where++import Composite.Record (Record)+import Control.Applicative (Alternative(empty, (<|>)))+import Control.Lens (Getter, view)+import Control.Monad (MonadPlus(mzero, mplus))+import Control.Monad.Base (MonadBase(liftBase))+import Control.Monad.Cont.Class (MonadCont(callCC))+import Control.Monad.Error.Class (MonadError(throwError, catchError))+import Control.Monad.Fail (MonadFail)+import qualified Control.Monad.Fail as MonadFail+import Control.Monad.Fix (MonadFix(mfix))+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Reader.Class (MonadReader(local, ask, reader))+import Control.Monad.RWS.Class (MonadRWS)+import Control.Monad.State.Class (MonadState(get, put, state))+import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.Trans.Control (MonadTransControl(type StT, liftWith, restoreT), MonadBaseControl(type StM, liftBaseWith, restoreM))+import Control.Monad.Writer.Class (MonadWriter(writer, tell, listen, pass))++-- |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+  -- |Fetch the context record from the environment.+  askContext :: m (Record c)++  -- |Run some action which has the same type of context with the context modified.+  localContext :: (Record c -> Record c) -> m a -> m a++-- |Project some value out of the context using a function.+asksContext :: MonadContext c m => (Record c -> a) -> m a+asksContext f = f <$> askContext++-- |Project some value out of the context using a lens (typically a field lens).+askField :: MonadContext c m => Getter (Record c) a -> m a+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 }++-- |Permute the current context with a function and then run some action with that modified context.+withContext :: (Record c' -> Record c) -> ContextT c m a -> ContextT c' m a+withContext f action = ContextT $ \ c' -> runContextT action (f c')++-- |Transform the monad underlying a 'ContextT' using a natural transform.+mapContextT :: (m a -> n b) -> ContextT c m a -> ContextT c n b+mapContextT f m = ContextT $ f . runContextT m++instance Monad m => MonadContext c (ContextT c m) where+  askContext = ContextT pure+  localContext f action = ContextT $ runContextT action . f++instance Functor m => Functor (ContextT c m) where+  fmap f clt = ContextT $ fmap f . runContextT clt++instance Applicative m => Applicative (ContextT c m) where+  pure = ContextT . const . pure+  cltab <*> clta = ContextT $ \ r -> runContextT cltab r <*> runContextT clta r++instance Alternative m => Alternative (ContextT c m) where+  empty = ContextT . const $ empty+  m <|> n = ContextT $ \ r -> runContextT m r <|> runContextT n r++instance Monad m => Monad (ContextT c m) where+  clt >>= k = ContextT $ \ ctx -> do+    a <- runContextT clt ctx+    runContextT (k a) ctx++  fail = ContextT . const . fail++instance MonadIO m => MonadIO (ContextT c m) where+  liftIO = lift . liftIO++instance MonadTrans (ContextT c) where+  lift = ContextT . const++instance MonadTransControl (ContextT c) where+  type StT (ContextT c) a = a+  liftWith f = ContextT $ \ r -> f $ \ t -> runContextT t r+  restoreT = ContextT . const++instance MonadBase b m => MonadBase b (ContextT c m) where+  liftBase = ContextT . const . liftBase++instance MonadBaseControl b m => MonadBaseControl b (ContextT c m) where+  type StM (ContextT c m) a = StM m a+  restoreM = ContextT . const . restoreM+  liftBaseWith f =+    ContextT $ \ c ->+      liftBaseWith $ \ runInBase ->+        f (runInBase . ($ c) . runContextT)++instance MonadReader r m => MonadReader r (ContextT c m) where+  ask    = lift ask+  local  = mapContextT . local+  reader = lift . reader++instance MonadWriter w m => MonadWriter w (ContextT c m) where+  writer = lift . writer+  tell   = lift . tell+  listen = mapContextT listen+  pass   = mapContextT pass++instance MonadState s m => MonadState s (ContextT c m) where+  get   = lift get+  put   = lift . put+  state = lift . state++instance MonadRWS r w s m => MonadRWS r w s (ContextT c m)++instance MonadFix m => MonadFix (ContextT c m) where+  mfix f = ContextT $ \ r -> mfix $ \ a -> runContextT (f a) r++instance MonadFail m => MonadFail (ContextT c m) where+  fail = lift . MonadFail.fail++instance MonadError e m => MonadError e (ContextT c m) where+  throwError = lift . throwError+  catchError m h = ContextT $ \ r -> catchError (runContextT m r) (\ e -> runContextT (h e) r)++instance MonadPlus m => MonadPlus (ContextT c m) where+  mzero = lift mzero+  m `mplus` n = ContextT $ \ r -> runContextT m r `mplus` runContextT n r++instance MonadCont m => MonadCont (ContextT c m) where+  callCC f = ContextT $ \ r -> callCC $ \ c -> runContextT (f (ContextT . const . c)) r

@@ -1,4 +1,3 @@-import BasicPrelude import RecordSpec (recordSuite) import Test.Hspec (hspec) 

@@ -1,6 +1,5 @@ module RecordSpec where -import BasicPrelude import Composite.Record import Composite.TH (withLensesAndProxies) import Control.Lens (view, set, _Just)@@ -16,14 +15,14 @@ recordSuite = do   describe "Basic record utilities" $ do     it "Supports construction and deconstruction of a Rec Identity" $ do-      let rec = 123 :*: "foo" :*: Nil :: Record TestRec-          foo :*: bar :*: Nil = rec+      let rec = 123 :*: "foo" :*: RNil :: Record TestRec+          foo :*: bar :*: RNil = rec       foo `shouldBe` 123       bar `shouldBe` "foo"      it "Supports construction and deconstruction of a Rec f" $ do-      let rec = Just 123 :^: Nothing :^: Nil :: Rec Maybe TestRec-          Just foo :^: Nothing :^: Nil = rec+      let rec = Just 123 :^: Nothing :^: RNil :: Rec Maybe TestRec+          Just foo :^: Nothing :^: RNil = rec       foo `shouldBe` 123      it "Supports pattern matching an Identity .: (:->)" $ do@@ -32,16 +31,16 @@       i `shouldBe` 123      it "Supports lensing in a Rec Identity" $ do-      let rec = 123 :*: "foo" :*: Nil :: Record TestRec+      let rec = 123 :*: "foo" :*: RNil :: Record TestRec       view (rlens fFoo_) rec `shouldBe` 123       view (rlens fBar_) rec `shouldBe` "foo"-      set (rlens fFoo_) 321   rec `shouldBe` (321 :*: "foo" :*: Nil)-      set (rlens fBar_) "bar" rec `shouldBe` (123 :*: "bar" :*: Nil)+      set (rlens fFoo_) 321   rec `shouldBe` (321 :*: "foo" :*: RNil)+      set (rlens fBar_) "bar" rec `shouldBe` (123 :*: "bar" :*: RNil)      it "Supports lensing in a Rec Maybe" $ do-      let rec = Just 123 :^: Nothing :^: Nil :: Rec Maybe TestRec+      let rec = Just 123 :^: Nothing :^: RNil :: Rec Maybe TestRec       view (rlens' fFoo_) rec `shouldBe` Just 123       view (rlens' fBar_) rec `shouldBe` Nothing-      set (rlens' fFoo_ . _Just) 321   rec `shouldBe` (Just 321 :^: Nothing :^: Nil)-      set (rlens' fBar_ . _Just) "bar" rec `shouldBe` (Just 123 :^: Nothing :^: Nil)+      set (rlens' fFoo_ . _Just) 321   rec `shouldBe` (Just 321 :^: Nothing :^: RNil)+      set (rlens' fBar_ . _Just) "bar" rec `shouldBe` (Just 123 :^: Nothing :^: RNil)