github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-26 00:12:29 +03:00
Code Issues Projects Releases Wiki Activity

Fix up the Readline effect & carrier.

Browse Source
This commit is contained in:
Rob Rix 2019-10-28 10:58:49 -04:00
parent bb7fb81c68
commit e4dfe76ce9
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
2 changed files with 18 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
semantic-analysis/src/Control/Carrier/Readline/Haskeline.hs
View File

@ -1,21 +1,18 @@
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeOperators, UndecidableInstances #-}
module Control.Carrier.Readline.Haskeline
( -- * Readline effect
module Control.Effect.Readline
-- * Readline carrier
, runReadline
( -- * Readline carrier
runReadline
, runReadlineWithHistory
, ReadlineC (..)
-- * Re-exports
, Carrier
, run
-- * Readline effect
, module Control.Effect.Readline
, runM
) where
import Control.Effect.Carrier
import Control.Effect.Lift
import Control.Effect.Reader
import Control.Effect.Readline hiding (Carrier)
import Control.Algebra
import Control.Carrier.Lift
import Control.Carrier.Reader
import Control.Effect.Readline
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Coerce
@ -48,14 +45,14 @@ runReadlineWithHistory block = do
newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT m)) a }
deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
instance MonadException m => Carrier Readline (ReadlineC m) where
eff (Prompt prompt k) = ReadlineC $ do
instance MonadException m => Algebra Readline (ReadlineC m) where
alg (Prompt prompt k) = ReadlineC $ do
str <- sendM (getInputLine @m (cyan <> prompt <> plain))
Line line <- ask
local increment (runReadlineC (k line str))
where cyan = "\ESC[1;36m\STX"
plain = "\ESC[0m\STX"
eff (Print doc k) = do
alg (Print doc k) = do
s <- maybe 80 Size.width <$> liftIO size
liftIO (renderIO stdout (layoutSmart defaultLayoutOptions { layoutPageWidth = AvailablePerLine s 0.8 } (doc <> line)))
k

13
semantic-analysis/src/Control/Effect/Readline.hs
View File

@ -5,10 +5,12 @@ module Control.Effect.Readline
, prompt
, print
-- * Re-exports
, Carrier
, Algebra
, Has
, run
) where
import Control.Effect.Carrier
import Control.Algebra
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import GHC.Generics (Generic1)
@ -19,12 +21,11 @@ data Readline m k
| Print (Doc AnsiStyle) (m k)
deriving (Functor, Generic1)
instance HFunctor Readline
instance Effect Readline
instance Effect Readline
prompt :: (Member Readline sig, Carrier sig m) => String -> m (Int, Maybe String)
prompt :: Has Readline sig m => String -> m (Int, Maybe String)
prompt p = send (Prompt p (curry pure))
print :: (Carrier sig m, Member Readline sig) => Doc AnsiStyle -> m ()
print :: Has Readline sig m => Doc AnsiStyle -> m ()
print s = send (Print s (pure ()))