github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

🔥 AskLine.

Browse Source
This commit is contained in:
Rob Rix 2019-10-10 15:38:17 -04:00
parent 859f856e09
commit c2764b76b6
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
2 changed files with 5 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
semantic-core/src/Control/Carrier/Readline/Haskeline.hs
View File

@ -49,11 +49,11 @@ newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT
instance (MonadException m, MonadIO m) => Carrier (Readline :+: Lift (InputT m)) (ReadlineC m) where
eff (L (Prompt prompt k)) = ReadlineC $ do
str <- lift (lift (getInputLine (cyan <> prompt <> plain)))
local increment (runReadlineC (k str))
line <- ask
local increment (runReadlineC (k line str))
where cyan = "\ESC[1;36m\STX"
plain = "\ESC[0m\STX"
eff (L (Print doc k)) = liftIO (putDoc doc) *> k
eff (L (AskLine k)) = ReadlineC ask >>= k
eff (R other) = ReadlineC (eff (R (handleCoercible other)))

11
semantic-core/src/Control/Effect/Readline.hs
View File

@ -5,7 +5,6 @@ module Control.Effect.Readline
, prompt
, print
, println
, askLine
-- * Line numbering
, Line (..)
, increment
@ -22,17 +21,16 @@ import GHC.Generics (Generic1)
import Prelude hiding (print)
data Readline m k
= Prompt String (Maybe String -> m k)
= Prompt String (Line -> Maybe String -> m k)
| Print (Doc AnsiStyle) (m k)
| AskLine (Line -> m k)
deriving (Functor, Generic1)
instance HFunctor Readline
instance Effect Readline
prompt :: (IsString str, Member Readline sig, Carrier sig m) => String -> m (Maybe str)
prompt p = fmap fromString <$> send (Prompt p pure)
prompt :: (IsString str, Member Readline sig, Carrier sig m) => String -> m (Line, Maybe str)
prompt p = fmap (fmap fromString) <$> send (Prompt p (curry pure))
print :: (Carrier sig m, Member Readline sig) => Doc AnsiStyle -> m ()
print s = send (Print s (pure ()))
@ -40,9 +38,6 @@ print s = send (Print s (pure ()))
println :: (Carrier sig m, Member Readline sig) => Doc AnsiStyle -> m ()
println s = print s >> print "\n"
askLine :: (Carrier sig m, Member Readline sig) => m Line
askLine = send (AskLine pure)
newtype Line = Line Int64