github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-01 11:46:14 +03:00
Code Issues Projects Releases Wiki Activity

Fix Algebra for REPL.

Browse Source
This commit is contained in:
Patrick Thomson 2019-11-08 13:39:13 -05:00
parent 3e6c84a48e
commit 89b8a50737
1 changed files with 7 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Control/Effect/REPL.hs
View File

@ -10,8 +10,8 @@ module Control.Effect.REPL
import Prologue
import Control.Effect.Carrier
import Control.Effect.Reader
import Control.Algebra
import Control.Carrier.Reader
import System.Console.Haskeline
import qualified Data.Text as T
@ -23,10 +23,10 @@ data REPL (m :: * -> *) k
instance HFunctor REPL
instance Effect REPL
prompt :: (Member REPL sig, Carrier sig m) => Text -> m (Maybe Text)
prompt :: Has REPL sig m => Text -> m (Maybe Text)
prompt p = send (Prompt p pure)
output :: (Member REPL sig, Carrier sig m) => Text -> m ()
output :: Has REPL sig m => Text -> m ()
output s = send (Output s (pure ()))
runREPL :: Prefs -> Settings IO -> REPLC m a -> m a
@ -35,13 +35,13 @@ runREPL prefs settings = runReader (prefs, settings) . runREPLC
newtype REPLC m a = REPLC { runREPLC :: ReaderC (Prefs, Settings IO) m a }
deriving (Functor, Applicative, Monad, MonadIO)
instance (Carrier sig m, MonadIO m) => Carrier (REPL :+: sig) (REPLC m) where
eff (L op) = do
instance (Algebra sig m, MonadIO m) => Algebra (REPL :+: sig) (REPLC m) where
alg (L op) = do
args <- REPLC ask
case op of
Prompt p k -> liftIO (uncurry runInputTWithPrefs args (fmap (fmap T.pack) (getInputLine (cyan <> T.unpack p <> plain)))) >>= k
Output s k -> liftIO (uncurry runInputTWithPrefs args (outputStrLn (T.unpack s))) *> k
eff (R other) = REPLC (eff (R (handleCoercible other)))
alg (R other) = REPLC (alg (R (handleCoercible other)))
cyan :: String