Get colored output in pseudo terminal, and add command to show the la…

…nguage server output

src/Common/ColorScheme.hs

@@ -55,7 +55,7 @@ data ColorScheme  = ColorScheme
                       , colorTypeSpecial :: Color
                       , colorTypeParam  :: Color
                       , colorNameQual   :: Color
-                      }
+                      } deriving (Show)
 
 -- | The default color scheme
 defaultColorScheme, darkColorScheme, lightColorScheme :: ColorScheme

src/Compiler/Compile.hs

@@ -355,7 +355,6 @@ compileProgramFromFile maybeContents contents term flags modules compileTarget r
   = do let fname = joinPath rootPath stem
        -- trace ("compileProgramFromFile: " ++ show fname ++ ", modules: " ++ show (map modName modules)) $ return ()
        liftIO $ termPhaseDoc term (color (colorInterpreter (colorScheme flags)) (text "compile:") <+> color (colorSource (colorScheme flags)) (text (normalizeWith '/' fname)))
-       liftIO $ termPhase term ("parsing " ++ fname)
        exist <- liftIO $ doesFileExist fname
        if (exist) then return () else liftError $ errorMsg (errorFileNotFound flags fname)
        program <- lift $ case contents of { Just x -> return $ parseProgramFromString (semiInsert flags) x fname; _ -> parseProgramFromFile (semiInsert flags) fname}
@@ -1044,9 +1043,6 @@ codeGen term flags compileTarget loaded
            ifaceDoc = Core.Pretty.prettyCore env{ coreIface = True } (target flags) inlineDefs (modCore mod) <-> Lib.PPrint.empty
 
        -- create output directory if it does not exist
-
-       do cwd <- getCurrentDirectory
-          termPhase term ("Create Dir " ++ cwd ++ "/" ++ dirname outBase)
        createDirectoryIfMissing True (dirname outBase)
 
        -- remove existing kki file in case of errors

src/LanguageServer/Handler/Commands.hs

@@ -6,7 +6,7 @@
 module LanguageServer.Handler.Commands (initializedHandler, commandHandler) where
 
 import Compiler.Options (Flags (outFinalPath))
-import Language.LSP.Server (Handlers, LspM, notificationHandler, sendNotification, MonadLsp, getVirtualFiles)
+import Language.LSP.Server (Handlers, LspM, notificationHandler, sendNotification, MonadLsp, getVirtualFiles, withIndefiniteProgress)
 import qualified Language.LSP.Protocol.Types as J
 import qualified Data.Text as T
 import LanguageServer.Monad (LSM, requestHandler)
@@ -19,6 +19,7 @@ import GHC.Base (Type)
 import LanguageServer.Handler.TextDocument (recompileFile)
 import Compiler.Compile (CompileTarget(..))
 import Common.Name (newName)
+import qualified Language.LSP.Server as J
 
 initializedHandler :: Flags -> Handlers LSM
 initializedHandler flags = notificationHandler J.SMethod_Initialized $ \_not -> sendNotification J.SMethod_WindowLogMessage $ J.LogMessageParams J.MessageType_Info "Initialized language server."
@@ -29,10 +30,10 @@ commandHandler flags = requestHandler J.SMethod_WorkspaceExecuteCommand $ \req r
   if command == "koka/genCode" then
     case commandParams of
       Just [Json.String filePath] -> do
-        sendNotification J.SMethod_WindowLogMessage $ J.LogMessageParams J.MessageType_Info $ T.pack ("Generating code for main file " ++ T.unpack filePath)
-        res <- recompileFile (Executable (newName "main") ()) flags (J.filePathToUri $ T.unpack filePath) Nothing True
-        sendNotification J.SMethod_WindowLogMessage $ J.LogMessageParams J.MessageType_Info $ T.pack ("Finished generating code for main file " ++ T.unpack filePath ++ " " ++ fromMaybe "No Compiled File" res)
-        resp $ Right $ case res of {Just filePath -> J.InL $ Json.String $ T.pack filePath; Nothing -> J.InR J.Null}
+        withIndefiniteProgress (T.pack "Compiling " <> filePath) J.NotCancellable $ do
+          res <- recompileFile (Executable (newName "main") ()) flags (J.filePathToUri $ T.unpack filePath) Nothing True
+          sendNotification J.SMethod_WindowLogMessage $ J.LogMessageParams J.MessageType_Info $ T.pack ("Finished generating code for main file " ++ T.unpack filePath ++ " " ++ fromMaybe "No Compiled File" res)
+          resp $ Right $ case res of {Just filePath -> J.InL $ Json.String $ T.pack filePath; Nothing -> J.InR J.Null}
       _ -> do
         sendNotification J.SMethod_WindowLogMessage $ J.LogMessageParams J.MessageType_Error $ T.pack "Invalid parameters"
         resp $ Right $ J.InR J.Null

src/LanguageServer/Handler/TextDocument.hs

@@ -80,7 +80,7 @@ recompileFile compileTarget flags uri version force =
             l <- loaded1
             return $ loadedModule l : loadedModules l
       term <- getTerminal
-      sendNotification J.SMethod_WindowLogMessage $ J.LogMessageParams J.MessageType_Info $ T.pack ("Recompiling " ++ show uri) <> T.pack filePath
+      sendNotification J.SMethod_WindowLogMessage $ J.LogMessageParams J.MessageType_Info $ T.pack $ "Recompiling " ++ filePath
       result <- liftIO $ compileFile (maybeContents vfs) contents term flags (fromMaybe [] modules) compileTarget filePath 
       outFile <- case checkError result of
         Right ((l, outFile), _) -> do

src/LanguageServer/Monad.hs

@@ -33,26 +33,57 @@ import qualified Language.LSP.Protocol.Types as J
 import qualified Language.LSP.Protocol.Message as J
 
 import Compiler.Compile (Terminal (..))
-import Control.Concurrent (Chan, forkIO)
-import Control.Concurrent.Chan (newChan, writeChan)
-import Lib.PPrint (Pretty(..), asString)
+import Lib.PPrint (Pretty(..), asString, writePrettyLn)
 import GHC.Conc (ThreadId)
 import Control.Concurrent.Chan (readChan)
-import Type.Pretty (ppType, defaultEnv)
+import Type.Pretty (ppType, defaultEnv, Env (context, importsMap), ppScheme)
 import Control.Concurrent (isEmptyMVar)
 import qualified Language.LSP.Server as J
 import GHC.Base (Type)
+import Lib.Printer (withColorPrinter, withColor, writeLn, ansiDefault, AnsiStringPrinter (AnsiString), Color (Red), ColorPrinter (PAnsiString))
+import Compiler.Options (Flags (..), prettyEnvFromFlags, verbose)
+import Common.Error (ppErrorMessage)
+import Common.ColorScheme (colorSource)
+import Common.Name (nameNil)
+import Kind.ImportMap (importsEmpty)
+import Platform.Var (newVar, takeVar)
+import Debug.Trace (trace)
 
 -- The language server's state, e.g. holding loaded/compiled modules.
-data LSState = LSState {lsLoaded :: Maybe Loaded, messages :: MVar [(String, J.MessageType)]}
+data LSState = LSState {lsLoaded :: Maybe Loaded, messages :: MVar [(String, J.MessageType)], flags:: Flags, terminal:: Terminal}
 
-defaultLSState :: IO LSState
-defaultLSState = do
-  msgVar <- newMVar []
-  return LSState {lsLoaded = Nothing, messages = msgVar}
+trimnl :: [Char] -> [Char]
+trimnl str = reverse $ dropWhile (`elem` "\n\r\t ") $ reverse str
 
-newLSStateVar :: IO (MVar LSState)
-newLSStateVar = defaultLSState >>= newMVar 
+defaultLSState :: Flags -> IO LSState
+defaultLSState flags = do
+  msgVar <- newMVar []
+  let withNewPrinter f = do
+        ansiConsole <- newVar ansiDefault
+        stringVar <- newVar ""
+        let p = AnsiString ansiConsole stringVar
+        tp <- (f . PAnsiString) p
+        ansiString <- takeVar stringVar
+        addMessages msgVar (trimnl ansiString, tp)
+
+  let cscheme = colorScheme flags
+      prettyEnv flags ctx imports = (prettyEnvFromFlags flags){ context = ctx, importsMap = imports }
+      term = Terminal (\err -> withNewPrinter $ \p -> do putErrorMessage p (showSpan flags) cscheme err; return J.MessageType_Error)
+                (if verbose flags > 1 then (\msg -> withNewPrinter $ \p -> do withColor p (colorSource cscheme) (writeLn p msg); return J.MessageType_Info)
+                                         else (\_ -> return ()))
+                 (if verbose flags > 0 then (\msg -> withNewPrinter $ \p -> do writePrettyLn p msg; return J.MessageType_Info) else (\_ -> return ()))
+                 (\tp -> withNewPrinter $ \p -> do putScheme p (prettyEnv flags nameNil importsEmpty) tp; return J.MessageType_Info)
+                 (\msg -> withNewPrinter $ \p -> do writePrettyLn p msg; return J.MessageType_Info)
+  return LSState {lsLoaded = Nothing, messages = msgVar, terminal = term, flags = flags}
+
+putScheme p env tp
+  = writePrettyLn p (ppScheme env tp)
+
+putErrorMessage p endToo cscheme err
+  = writePrettyLn p (ppErrorMessage endToo cscheme err)
+
+newLSStateVar :: Flags -> IO (MVar LSState)
+newLSStateVar flags = defaultLSState flags >>= newMVar
 
 -- The monad holding (thread-safe) state used by the language server.
 type LSM = LspT () (ReaderT (MVar LSState) IO)
@@ -100,7 +131,7 @@ notificationHandler method handler = J.notificationHandler method $ \req -> do
 requestHandler :: forall (m :: J.Method 'J.ClientToServer 'J.Request). J.SMethod m -> J.Handler LSM m -> Handlers LSM
 requestHandler method handler = J.requestHandler method $ \req resp -> do
   handler req resp
-  flushMessages  
+  flushMessages
 
 flushMessages :: LSM ()
 flushMessages = do
@@ -113,12 +144,4 @@ addMessages msgVar msg =
   modifyMVar msgVar (\oldMsgs -> return (oldMsgs ++ [msg], ()))
 
 getTerminal :: LSM Terminal
-getTerminal = do
-  msgVar <- messages <$> getLSState
-  return $ Terminal
-    { termError = \err -> addMessages msgVar (show err, J.MessageType_Error),
-      termPhase = \phase -> addMessages msgVar (phase, J.MessageType_Info),
-      termPhaseDoc = \doc -> addMessages msgVar (asString doc, J.MessageType_Info),
-      termType = \ty -> addMessages msgVar (asString $ ppType defaultEnv ty, J.MessageType_Info),
-      termDoc = \doc -> addMessages msgVar (asString doc, J.MessageType_Info)
-    }
+getTerminal = terminal <$> getLSState

src/LanguageServer/Run.hs

@@ -21,7 +21,7 @@ import GHC.IO.IOMode (IOMode(ReadWriteMode))
 
 runLanguageServer :: Flags -> [FilePath] -> IO ()
 runLanguageServer flags files = do
-  state <- newLSStateVar 
+  state <- newLSStateVar flags
   connect "localhost" (show $ languageServerPort flags) (\(socket, _) -> do 
     handle <- socketToHandle socket ReadWriteMode
     void $