mirror of
https://github.com/github/semantic.git
synced 2024-11-23 08:27:56 +03:00
Merge pull request #412 from github/the-thin-read-line
Use fused-effects-readline package rather than a custom implementation.
This commit is contained in:
Patrick Thomson
GitHub
commit
f2f6c8eb94
@ -43,3 +43,8 @@ source-repository-package
|
||||
type: git
|
||||
location: https://github.com/antitypical/fused-syntax.git
|
||||
tag: d11e14581217590a5c67f79cbaeee35ac8acee6a
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/fused-effects/fused-effects-readline.git
|
||||
tag: 7a96949c77c73c6e5975c8d6171ffb63eb76b467
|
||||
|
||||
@ -48,17 +48,16 @@ library
|
||||
Analysis.ScopeGraph
|
||||
Analysis.Typecheck
|
||||
Control.Carrier.Fail.WithLoc
|
||||
Control.Carrier.Readline.Haskeline
|
||||
Control.Effect.Readline
|
||||
build-depends:
|
||||
algebraic-graphs ^>= 0.3
|
||||
, base >= 4.13 && < 5
|
||||
, containers ^>= 0.6
|
||||
, fused-effects ^>= 1.0
|
||||
, fused-effects-readline
|
||||
, fused-syntax
|
||||
, haskeline ^>= 0.7.5
|
||||
, pathtype ^>= 0.8.1
|
||||
, prettyprinter >= 1.2.1 && < 1.4
|
||||
, prettyprinter >= 1.2 && < 2
|
||||
, prettyprinter-ansi-terminal ^>= 1.1.1
|
||||
, semantic-source ^>= 0
|
||||
, terminal-size ^>= 0.3
|
||||
|
||||
@ -1,64 +0,0 @@
|
||||
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeOperators, UndecidableInstances #-}
|
||||
module Control.Carrier.Readline.Haskeline
|
||||
( -- * Readline carrier
|
||||
runReadline
|
||||
, runReadlineWithHistory
|
||||
, ReadlineC (..)
|
||||
-- * Readline effect
|
||||
, module Control.Effect.Readline
|
||||
, runM
|
||||
) where
|
||||
|
||||
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
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import Data.Text.Prettyprint.Doc.Render.Terminal (renderIO)
|
||||
import System.Console.Haskeline hiding (Handler, handle)
|
||||
import System.Console.Terminal.Size as Size
|
||||
import System.Path ((</>))
|
||||
import qualified System.Path as Path
|
||||
import System.Path.Directory
|
||||
import System.IO (stdout)
|
||||
|
||||
runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
|
||||
runReadline prefs settings = runInputTWithPrefs prefs (coerce settings) . runM . runReader (Line 0) . runReadlineC
|
||||
|
||||
runReadlineWithHistory :: MonadException m => ReadlineC m a -> m a
|
||||
runReadlineWithHistory block = do
|
||||
homeDir <- liftIO getHomeDirectory
|
||||
prefs <- liftIO $ readPrefs (Path.toString (homeDir </> Path.relFile ".haskeline"))
|
||||
let settingsDir = homeDir </> Path.relDir ".local" </> Path.relDir "semantic-core"
|
||||
settings = Settings
|
||||
{ complete = noCompletion
|
||||
, historyFile = Just (Path.toString (settingsDir </> Path.relFile "repl_history"))
|
||||
, autoAddHistory = True
|
||||
}
|
||||
liftIO $ createDirectoryIfMissing True settingsDir
|
||||
|
||||
runReadline prefs settings block
|
||||
|
||||
newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT m)) a }
|
||||
deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
|
||||
|
||||
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"
|
||||
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
|
||||
|
||||
|
||||
newtype Line = Line Int
|
||||
|
||||
increment :: Line -> Line
|
||||
increment (Line n) = Line (n + 1)
|
||||
@ -1,32 +0,0 @@
|
||||
{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, MultiParamTypeClasses #-}
|
||||
module Control.Effect.Readline
|
||||
( -- * Readline effect
|
||||
Readline (..)
|
||||
, prompt
|
||||
, print
|
||||
-- * Re-exports
|
||||
, Algebra
|
||||
, Has
|
||||
, run
|
||||
) where
|
||||
|
||||
import Control.Algebra
|
||||
import Data.Text.Prettyprint.Doc
|
||||
import Data.Text.Prettyprint.Doc.Render.Terminal
|
||||
import GHC.Generics (Generic1)
|
||||
import Prelude hiding (print)
|
||||
|
||||
data Readline m k
|
||||
= Prompt String (Int -> Maybe String -> m k)
|
||||
| Print (Doc AnsiStyle) (m k)
|
||||
deriving (Functor, Generic1)
|
||||
|
||||
instance HFunctor Readline
|
||||
instance Effect Readline
|
||||
|
||||
|
||||
prompt :: Has Readline sig m => String -> m (Int, Maybe String)
|
||||
prompt p = send (Prompt p (curry pure))
|
||||
|
||||
print :: Has Readline sig m => Doc AnsiStyle -> m ()
|
||||
print s = send (Print s (pure ()))
|
||||
@ -51,7 +51,7 @@ library
|
||||
, fused-syntax
|
||||
, parsers ^>= 0.12.10
|
||||
, pathtype ^>= 0.8.1
|
||||
, prettyprinter >= 1.2.1 && < 1.4
|
||||
, prettyprinter >= 1.2.1 && < 2
|
||||
, prettyprinter-ansi-terminal ^>= 1.1.1
|
||||
, semantic-analysis ^>= 0
|
||||
, semantic-source ^>= 0
|
||||
|
||||
@ -278,7 +278,7 @@ library
|
||||
, optparse-applicative >= 0.14.3 && < 0.16
|
||||
, parallel ^>= 3.2.2.0
|
||||
, parsers ^>= 0.12.9
|
||||
, prettyprinter >= 1.2.1 && < 1.4
|
||||
, prettyprinter >= 1.2 && < 2
|
||||
, pretty-show ^>= 1.9.5
|
||||
, profunctors ^>= 5.3
|
||||
, proto-lens >= 0.5 && < 0.7
|
||||
|
||||
Loading…
Reference in New Issue
Block a user