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.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 diff --git a/src/Composite.hs b/src/Composite.hs --- a/src/Composite.hs +++ b/src/Composite.hs @@ -1,8 +1,6 @@ module Composite - ( module Composite.Base - , module Composite.Record + ( module Composite.Record ) where -import Composite.Base import Composite.Record diff --git a/src/Composite/Base.hs b/src/Composite/Base.hs deleted file mode 100644 --- a/src/Composite/Base.hs +++ /dev/null @@ -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) diff --git a/src/Composite/Record.hs b/src/Composite/Record.hs --- a/src/Composite/Record.hs +++ b/src/Composite/Record.hs @@ -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' #-} diff --git a/src/Composite/TH.hs b/src/Composite/TH.hs --- a/src/Composite/TH.hs +++ b/src/Composite/TH.hs @@ -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) diff --git a/src/Control/Monad/Composite/Context.hs b/src/Control/Monad/Composite/Context.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Composite/Context.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,3 @@ -import BasicPrelude import RecordSpec (recordSuite) import Test.Hspec (hspec) diff --git a/test/RecordSpec.hs b/test/RecordSpec.hs --- a/test/RecordSpec.hs +++ b/test/RecordSpec.hs @@ -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)