1
1
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00

Don’t allow messages to be sent to the InputT.

This commit is contained in:
Rob Rix 2019-10-10 16:53:03 -04:00
parent 2e61978b98
commit b709219b77
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7

View File

@ -47,18 +47,17 @@ runReadlineWithHistory block = do
newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT (UnliftIOToMonadException m))) a }
deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
instance MonadUnliftIO m => Carrier (Readline :+: Lift (InputT (UnliftIOToMonadException m))) (ReadlineC m) where
eff (L (Prompt prompt k)) = ReadlineC $ do
instance MonadUnliftIO m => Carrier Readline (ReadlineC m) where
eff (Prompt prompt k) = ReadlineC $ do
str <- sendM (getInputLine @(UnliftIOToMonadException m) (cyan <> prompt <> plain))
Line line <- ask
local increment (runReadlineC (k line str))
where cyan = "\ESC[1;36m\STX"
plain = "\ESC[0m\STX"
eff (L (Print doc k)) = do
eff (Print doc k) = do
s <- maybe 80 Size.width <$> liftIO size
liftIO (renderIO stdout (layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine s 0.8 } (doc <> line)))
k
eff (R other) = ReadlineC (eff (R (handleCoercible other)))
-- | This exists to work around the 'MonadException' constraint that haskeline entails.