add terminal.raw

Author: tomaz1502

Lam.cabal

@@ -36,6 +36,7 @@ library
     Lam.TypeChecker
     Lam.Utils
     Lam.UtilsAgda
+    Lam.Terminal.Raw
     Lam.Terminal.ReadRepl
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Lam/Handler.hs

@@ -10,10 +10,6 @@ module Lam.Handler ( replWrapper
 import Control.Monad.RWS        ( get, put )
 import Control.Monad.Except     ( liftEither, MonadIO(liftIO), MonadError (..) )
 import Data.Map qualified as M
-import System.Posix
-    ( stdInput,
-      getTerminalAttributes,
-      TerminalState(Immediately) )
 
 import Lam.Context
 import Lam.Data
@@ -22,8 +18,8 @@ import Lam.Parser
 import Lam.Result
 import Lam.TypeChecker
 import Lam.Utils
+import Lam.Terminal.Raw
 import Lam.Terminal.ReadRepl
-import System.Posix.Terminal (setTerminalAttributes)
 
 -- TODO: report cyclic dependencies
 loadFile :: String -> Result ()
@@ -74,15 +70,15 @@ handleCommand c =
     EvalC rExpr                     -> handleEval rExpr
     LoadC path                      -> loadFile path
     ReadC varName                   -> do
-        exprS <- liftIO getLine
+        exprS <- liftIO (readRepl [] "")
         isUntyped <- askUntyped
         expr <- liftEither (parseRawExpr isUntyped exprS)
         handleDefine varName expr
     ExitC -> return ()
 
 repl :: CmdHistory -> Result ()
 repl h = do
-  cmdStr <- liftIO (readRepl h)
+  cmdStr <- liftIO (readRepl h "> ")
   let h' = if null cmdStr then h else cmdStr : h
   isUntyped <- askUntyped
   case parseCommand isUntyped cmdStr of
@@ -95,11 +91,7 @@ repl h = do
         repl h'
 
 replWrapper :: Result ()
-replWrapper = do
-  startingAttrs <- liftIO (getTerminalAttributes stdInput)
-  liftIO (setRawMode startingAttrs)
-  repl []
-  liftIO (setTerminalAttributes stdInput startingAttrs Immediately)
+replWrapper = runInRawMode (repl [])
 
 handleFile :: String -> Result ()
 handleFile fName = do

src/Lam/Terminal/Raw.hs

@@ -0,0 +1,27 @@
+module Lam.Terminal.Raw where
+
+import System.Posix.Terminal
+import System.Posix (stdInput)
+import Control.Monad.Cont (MonadIO, liftIO)
+
+withRawMode :: TerminalAttributes -> TerminalAttributes
+withRawMode attrs =
+  let withoutMode' = flip withoutMode in
+      foldl (\a fn -> fn a) attrs
+        [ withoutMode' EnableEcho
+        , withoutMode' ProcessInput
+        , withoutMode' ExtendedFunctions
+        ]
+
+setRawMode :: TerminalAttributes -> IO ()
+setRawMode attrs = do
+  let rawAttrs = withRawMode attrs
+  setTerminalAttributes stdInput rawAttrs Immediately
+
+runInRawMode :: MonadIO m => m a -> m a
+runInRawMode m = do
+  attrs <- liftIO (getTerminalAttributes stdInput)
+  liftIO (setRawMode attrs)
+  a <- m
+  liftIO (setTerminalAttributes stdInput attrs Immediately)
+  return a

src/Lam/Terminal/ReadRepl.hs

@@ -5,8 +5,6 @@ import System.Console.ANSI
 import GHC.IO.Handle
 import GHC.IO.StdHandles
 import System.IO (hReady)
-import System.Posix.Terminal
-import System.Posix (stdInput)
 
 type CmdHistory = [String]
 
@@ -22,21 +20,20 @@ update [] _ _ = []
 update (_ : tl) 0 a = a : tl
 update (hd : tl) i a = hd : update tl (i - 1) a
 
-readRepl :: CmdHistory -> IO String
-readRepl originalHistory =
+readRepl :: CmdHistory -> String -> IO String
+readRepl originalHistory prompt =
   loop 0 0 ("" : originalHistory)
   where
     loop pos hisPos history = do
       let cmd = history !! hisPos
       setCursorColumn 0
       clearLine
-      putStr ("> " ++ cmd)
-      setCursorColumn (pos + 2)
+      putStr (prompt ++ cmd)
+      setCursorColumn (pos + length prompt)
       hFlush stdout
       k <- getKey
       case k of
-        "\n" ->
-            putStr "\n" >> return cmd
+        "\n" -> putStr "\n" >> return cmd
         "\ESC[A" -> -- up
             let hisPos' = min (hisPos + 1) (length history - 1) in
             let pos' = length (history !! hisPos') in
@@ -57,17 +54,3 @@ readRepl originalHistory =
             let cmd' = take pos cmd ++ k ++ drop pos cmd in
             let history' = update history hisPos cmd' in
             loop (min (pos + 1) (length cmd')) hisPos history'
-
-setRawMode :: TerminalAttributes -> IO ()
-setRawMode attrs = do
-  let rawAttrs = withRawMode attrs
-  setTerminalAttributes stdInput rawAttrs Immediately
-
-withRawMode :: TerminalAttributes -> TerminalAttributes
-withRawMode attrs =
-  let withoutMode' = flip withoutMode in
-      foldl (\a f -> f a) attrs
-        [ withoutMode' EnableEcho
-        , withoutMode' ProcessInput
-        , withoutMode' ExtendedFunctions
-        ]