github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-27 03:09:48 +03:00
Code Issues Projects Releases Wiki Activity

Delete old implementations.

Browse Source
This commit is contained in:
Patrick Thomson 2019-12-18 11:23:38 -05:00
parent 3d1c102019
commit 7f1190abaf
2 changed files with 0 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)

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

@ -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 ()))