diff --git a/examples/Processor.hs b/examples/Processor.hs index f44500a..4752185 100644 --- a/examples/Processor.hs +++ b/examples/Processor.hs @@ -1,29 +1,41 @@ -{-# LANGUAGE ConstraintKinds, DeriveFunctor, GADTs, FlexibleContexts, LambdaCase #-} +{-# LANGUAGE ConstraintKinds, DeriveFunctor, GADTs, LambdaCase #-} +{-# LANGUAGE FunctionalDependencies, FlexibleContexts, FlexibleInstances #-} + module Processor where import Control.Selective import Control.Selective.Rigid.Free -import Data.Functor import Data.Bool +import Data.Functor import Data.Int (Int16) -import Data.Word (Word8) import Data.Map.Strict (Map) +import Data.Word (Word8) +import Foreign.Marshal.Utils (fromBool) import Prelude hiding (read, log) -import qualified Control.Monad.State as S -import qualified Data.Map.Strict as Map +import qualified Control.Monad.Trans.State as S +import qualified Data.Map.Strict as Map -- See Section 5.3 of the paper: -- https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf -- Note that we have changed the naming. --- | Hijack @mtl@'s 'MonadState' constraint to include Selective. -type MonadState s m = (Selective m, S.MonadState s m) +-- | A standard @MonadState@ class extended with the 'Selective' interface. +class (Selective m, Monad m) => MonadState s m | m -> s where + get :: m s + put :: s -> m () + state :: (s -> (a, s)) -> m a + +instance Monad m => MonadState s (S.StateT s m) where + get = S.get + put = S.put + state = S.state + +gets :: MonadState s m => (s -> a) -> m a +gets f = f <$> get --- | Convert a 'Bool' to @0@ or @1@. -fromBool :: Num a => Bool -> a -fromBool True = 1 -fromBool False = 0 +modify :: MonadState s m => (s -> s) -> m () +modify f = state (\s -> ((), f s)) -------------------------------------------------------------------------------- -------- Types ----------------------------------------------------------------- @@ -94,16 +106,16 @@ instance Show (RW a) where show (Write k _ _) = "Write " ++ show k logEntry :: MonadState State m => LogEntry Key Value -> m () -logEntry item = S.modify $ \s -> s { log = log s ++ [item] } +logEntry item = modify $ \s -> s { log = log s ++ [item] } -- | Interpret the base functor in a 'MonadState'. toState :: MonadState State m => RW a -> m a toState = \case (Read k t) -> do - v <- case k of Reg r -> S.gets ((Map.! r) . registers) - Cell addr -> S.gets ((Map.! addr) . memory) - Flag f -> S.gets ((Map.! f) . flags) - PC -> S.gets pc + v <- case k of Reg r -> gets ((Map.! r) . registers) + Cell addr -> gets ((Map.! addr) . memory) + Flag f -> gets ((Map.! f) . flags) + PC -> gets pc logEntry (ReadEntry k v) pure (t v) (Write k p t) -> do @@ -111,14 +123,14 @@ toState = \case logEntry (WriteEntry k v) case k of Reg r -> let regs' s = Map.insert r v (registers s) - in S.state (\s -> (t v, s {registers = regs' s})) + in state (\s -> (t v, s {registers = regs' s})) Cell addr -> let mem' s = Map.insert addr v (memory s) - in S.state (\s -> (t v, s {memory = mem' s})) + in state (\s -> (t v, s {memory = mem' s})) Flag f -> let flags' s = Map.insert f v (flags s) - in S.state (\s -> (t v, s {flags = flags' s})) - PC -> S.state (\s -> (t v, s {pc = v})) + in state (\s -> (t v, s {flags = flags' s})) + PC -> state (\s -> (t v, s {pc = v})) --- | Interpret a program as a state trasformer. +-- | Interpret a program as a state transformer. runProgramState :: Program a -> State -> (a, State) runProgramState f = S.runState (runSelect toState f) diff --git a/selective.cabal b/selective.cabal index 8cc5d36..3ef27a9 100644 --- a/selective.cabal +++ b/selective.cabal @@ -52,6 +52,8 @@ library -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + if impl(ghc >= 9.2) + ghc-options: -Wno-operator-whitespace-ext-conflict test-suite test hs-source-dirs: test, examples @@ -68,7 +70,6 @@ test-suite test main-is: Main.hs build-depends: base >= 4.7 && < 5, containers >= 0.5.5.1 && < 0.7, - mtl >= 2.2.1 && < 2.3, QuickCheck >= 2.8 && < 2.15, selective, tasty >= 0.11, @@ -82,3 +83,5 @@ test-suite test -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints + if impl(ghc >= 9.2) + ghc-options: -Wno-operator-whitespace-ext-conflict diff --git a/test/Sketch.hs b/test/Sketch.hs index 64d0bc9..f8b92bb 100644 --- a/test/Sketch.hs +++ b/test/Sketch.hs @@ -565,7 +565,7 @@ data Result a = Done a | Blocked BlockedRequests (Haxl a) deriving Functor newtype Haxl a = Haxl { runHaxl :: IO (Result a) } deriving Functor instance Applicative Haxl where - pure = return + pure = Haxl . return . Done Haxl iof <*> Haxl iox = Haxl $ do rf <- iof @@ -586,7 +586,7 @@ instance Selective Haxl where (Blocked bx x , Blocked bf f) -> Blocked (bx <> bf) (select x f) -- speculative -- execution instance Monad Haxl where - return = Haxl . return . Done + return = pure Haxl iox >>= f = Haxl $ do rx <- iox