Lsp

.github/workflows/ci.yml

@@ -2,9 +2,9 @@ name: "CI"
 
 on:
   push:
-    branches: [ "master" ]
+    branches: [ "master", "oa-fork" ]
   pull_request:
-    branches: [ "master" ]
+    branches: [ "master", "oa-fork" ]
     paths:
       - .github/workflows/**/*.yml
       - app/**/*

app/Command/Compile.hs

@@ -1,8 +1,6 @@
 module Command.Compile (command) where
 
-import Prelude
-
-import Control.Applicative (Alternative(..))
+import Control.Applicative (Alternative (..))
 import Control.Monad (when)
 import Data.Aeson qualified as A
 import Data.Bool (bool)
@@ -13,34 +11,36 @@ import Data.Set qualified as S
 import Data.Text qualified as T
 import Data.Traversable (for)
 import Language.PureScript qualified as P
-import Language.PureScript.CST qualified as CST
-import Language.PureScript.Errors.JSON (JSONResult(..), toJSONErrors)
-import Language.PureScript.Glob (toInputGlobs, PSCGlobs(..), warnFileTypeNotFound)
-import Language.PureScript.Make (buildMakeActions, inferForeignModules, runMake)
+import Language.PureScript.Compile qualified as P 
+import Language.PureScript.DB (mkConnection)
+import Language.PureScript.Errors.JSON (JSONResult (..), toJSONErrors)
+import Language.PureScript.Glob (PSCGlobs (..), toInputGlobs, warnFileTypeNotFound)
+import Language.PureScript.Make.Index (initDb)
 import Options.Applicative qualified as Opts
 import SharedCLI qualified
 import System.Console.ANSI qualified as ANSI
-import System.Exit (exitSuccess, exitFailure)
 import System.Directory (getCurrentDirectory)
+import System.Exit (exitFailure, exitSuccess)
 import System.IO (hPutStr, stderr, stdout)
 import System.IO.UTF8 (readUTF8FilesT)
+import Prelude
 
 data PSCMakeOptions = PSCMakeOptions
-  { pscmInput        :: [FilePath]
-  , pscmInputFromFile :: Maybe FilePath
-  , pscmExclude      :: [FilePath]
-  , pscmOutputDir    :: FilePath
-  , pscmOpts         :: P.Options
-  , pscmUsePrefix    :: Bool
-  , pscmJSONErrors   :: Bool
+  { pscmInput :: [FilePath],
+    pscmInputFromFile :: Maybe FilePath,
+    pscmExclude :: [FilePath],
+    pscmOutputDir :: FilePath,
+    pscmOpts :: P.Options,
+    pscmUsePrefix :: Bool,
+    pscmJSONErrors :: Bool
   }
 
 -- | Arguments: verbose, use JSON, warnings, errors
 printWarningsAndErrors :: Bool -> Bool -> [(FilePath, T.Text)] -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
 printWarningsAndErrors verbose False files warnings errors = do
   pwd <- getCurrentDirectory
   cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stdout
-  let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd, P.ppeFileContents = files }
+  let ppeOpts = P.defaultPPEOptions {P.ppeCodeColor = cc, P.ppeFull = verbose, P.ppeRelativeDirectory = pwd, P.ppeFileContents = files}
   when (P.nonEmpty warnings) $
     putStrLn (P.prettyPrintMultipleWarnings ppeOpts warnings)
   case errors of
@@ -50,86 +50,96 @@ printWarningsAndErrors verbose False files warnings errors = do
     Right _ -> return ()
 printWarningsAndErrors verbose True files warnings errors = do
   putStrLn . LBU8.toString . A.encode $
-    JSONResult (toJSONErrors verbose P.Warning files warnings)
-               (either (toJSONErrors verbose P.Error files) (const []) errors)
+    JSONResult
+      (toJSONErrors verbose P.Warning files warnings)
+      (either (toJSONErrors verbose P.Error files) (const []) errors)
   either (const exitFailure) (const (return ())) errors
 
 compile :: PSCMakeOptions -> IO ()
-compile PSCMakeOptions{..} = do
-  input <- toInputGlobs $ PSCGlobs
-    { pscInputGlobs = pscmInput
-    , pscInputGlobsFromFile = pscmInputFromFile
-    , pscExcludeGlobs = pscmExclude
-    , pscWarnFileTypeNotFound = warnFileTypeNotFound "compile"
-    }
+compile PSCMakeOptions {..} = do
+  input <-
+    toInputGlobs $
+      PSCGlobs
+        { pscInputGlobs = pscmInput,
+          pscInputGlobsFromFile = pscmInputFromFile,
+          pscExcludeGlobs = pscmExclude,
+          pscWarnFileTypeNotFound = warnFileTypeNotFound "compile"
+        }
   when (null input) $ do
-    hPutStr stderr $ unlines [ "purs compile: No input files."
-                             , "Usage: For basic information, try the `--help' option."
-                             ]
+    hPutStr stderr $
+      unlines
+        [ "purs compile: No input files.",
+          "Usage: For basic information, try the `--help' option."
+        ]
     exitFailure
+  (_, conn) <- mkConnection pscmOutputDir
+  initDb conn
   moduleFiles <- readUTF8FilesT input
-  (makeErrors, makeWarnings) <- runMake pscmOpts $ do
-    ms <- CST.parseModulesFromFiles id moduleFiles
-    let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
-    foreigns <- inferForeignModules filePathMap
-    let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
-    P.make makeActions (map snd ms)
+  (makeErrors, makeWarnings) <- P.compile pscmOpts moduleFiles conn pscmOutputDir pscmUsePrefix
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
   exitSuccess
 
+
+
 outputDirectory :: Opts.Parser FilePath
-outputDirectory = Opts.strOption $
-     Opts.short 'o'
-  <> Opts.long "output"
-  <> Opts.value "output"
-  <> Opts.showDefault
-  <> Opts.help "The output directory"
+outputDirectory =
+  Opts.strOption $
+    Opts.short 'o'
+      <> Opts.long "output"
+      <> Opts.value "output"
+      <> Opts.showDefault
+      <> Opts.help "The output directory"
 
 comments :: Opts.Parser Bool
-comments = Opts.switch $
-     Opts.short 'c'
-  <> Opts.long "comments"
-  <> Opts.help "Include comments in the generated code"
+comments =
+  Opts.switch $
+    Opts.short 'c'
+      <> Opts.long "comments"
+      <> Opts.help "Include comments in the generated code"
 
 verboseErrors :: Opts.Parser Bool
-verboseErrors = Opts.switch $
-     Opts.short 'v'
-  <> Opts.long "verbose-errors"
-  <> Opts.help "Display verbose error messages"
+verboseErrors =
+  Opts.switch $
+    Opts.short 'v'
+      <> Opts.long "verbose-errors"
+      <> Opts.help "Display verbose error messages"
 
 noPrefix :: Opts.Parser Bool
-noPrefix = Opts.switch $
-     Opts.short 'p'
-  <> Opts.long "no-prefix"
-  <> Opts.help "Do not include comment header"
+noPrefix =
+  Opts.switch $
+    Opts.short 'p'
+      <> Opts.long "no-prefix"
+      <> Opts.help "Do not include comment header"
 
 jsonErrors :: Opts.Parser Bool
-jsonErrors = Opts.switch $
-     Opts.long "json-errors"
-  <> Opts.help "Print errors to stderr as JSON"
+jsonErrors =
+  Opts.switch $
+    Opts.long "json-errors"
+      <> Opts.help "Print errors to stderr as JSON"
 
 codegenTargets :: Opts.Parser [P.CodegenTarget]
-codegenTargets = Opts.option targetParser $
-     Opts.short 'g'
-  <> Opts.long "codegen"
-  <> Opts.value [P.JS]
-  <> Opts.help
-      ( "Specifies comma-separated codegen targets to include. "
-      <> targetsMessage
-      <> " The default target is 'js', but if this option is used only the targets specified will be used."
-      )
+codegenTargets =
+  Opts.option targetParser $
+    Opts.short 'g'
+      <> Opts.long "codegen"
+      <> Opts.value [P.JS]
+      <> Opts.help
+        ( "Specifies comma-separated codegen targets to include. "
+            <> targetsMessage
+            <> " The default target is 'js', but if this option is used only the targets specified will be used."
+        )
 
 targetsMessage :: String
 targetsMessage = "Accepted codegen targets are '" <> intercalate "', '" (M.keys P.codegenTargets) <> "'."
 
 targetParser :: Opts.ReadM [P.CodegenTarget]
 targetParser =
   Opts.str >>= \s ->
-    for (T.split (== ',') s)
-      $ maybe (Opts.readerError targetsMessage) pure
-      . flip M.lookup P.codegenTargets
-      . T.unpack
-      . T.strip
+    for (T.split (== ',') s) $
+      maybe (Opts.readerError targetsMessage) pure
+        . flip M.lookup P.codegenTargets
+        . T.unpack
+        . T.strip
 
 options :: Opts.Parser P.Options
 options =
@@ -143,13 +153,15 @@ options =
     handleTargets ts = S.fromList (if P.JSSourceMap `elem` ts then P.JS : ts else ts)
 
 pscMakeOptions :: Opts.Parser PSCMakeOptions
-pscMakeOptions = PSCMakeOptions <$> many SharedCLI.inputFile
-                                <*> SharedCLI.globInputFile
-                                <*> many SharedCLI.excludeFiles
-                                <*> outputDirectory
-                                <*> options
-                                <*> (not <$> noPrefix)
-                                <*> jsonErrors
+pscMakeOptions =
+  PSCMakeOptions
+    <$> many SharedCLI.inputFile
+    <*> SharedCLI.globInputFile
+    <*> many SharedCLI.excludeFiles
+    <*> outputDirectory
+    <*> options
+    <*> (not <$> noPrefix)
+    <*> jsonErrors
 
 command :: Opts.Parser (IO ())
 command = compile <$> (Opts.helper <*> pscMakeOptions)

app/Command/Ide.hs

@@ -178,6 +178,9 @@ command = Opts.helper <*> subcommands where
     "none" -> LogNone
     _ -> LogDefault
 
+
+-- runM env 
+
 startServer :: Network.PortNumber -> IdeEnvironment -> IO ()
 startServer port env = Network.withSocketsDo $ do
   sock <- listenOnLocalhost port

app/Command/Lsp.hs

@@ -0,0 +1,48 @@
+module Command.Lsp (command) where
+
+import Language.PureScript.Lsp as Lsp
+import Language.PureScript.Lsp.Types (mkEnv)
+import Options.Applicative qualified as Opts
+import Protolude
+import System.Directory (setCurrentDirectory)
+
+data ServerOptions = ServerOptions
+  { _serverDirectory :: Maybe FilePath,
+    _serverOutputPath :: FilePath
+  }
+  deriving (Show)
+
+command :: Opts.Parser (IO ())
+command = Opts.helper <*> subcommands
+  where
+    subcommands :: Opts.Parser (IO ())
+    subcommands =
+      (Opts.subparser . fold)
+        [ Opts.command
+            "server"
+            ( Opts.info
+                (fmap server serverOptions <**> Opts.helper)
+                (Opts.progDesc "Start a server LSP process")
+            )
+        ]
+
+    server :: ServerOptions -> IO ()
+    server (ServerOptions dir outputPath) = do
+      maybe (pure ()) setCurrentDirectory dir
+      putErrLn $ "Starting server with output path: " <> outputPath
+      env <- mkEnv outputPath
+      startServer outputPath env
+
+    serverOptions :: Opts.Parser ServerOptions
+    serverOptions =
+      ServerOptions
+        <$> optional (Opts.strOption (Opts.long "directory" `mappend` Opts.short 'd'))
+        <*> Opts.strOption (Opts.long "output-directory" `mappend` Opts.value "output/")
+
+    startServer outputPath env = do
+      code <- Lsp.main outputPath env
+      exitWith
+        ( case code of
+            0 -> ExitSuccess
+            _ -> ExitFailure code
+        )

app/Main.hs

@@ -8,6 +8,7 @@ import Command.Docs qualified as Docs
 import Command.Graph qualified as Graph
 import Command.Hierarchy qualified as Hierarchy
 import Command.Ide qualified as Ide
+import Command.Lsp qualified as Lsp
 import Command.Publish qualified as Publish
 import Command.REPL qualified as REPL
 import Control.Monad (join)
@@ -76,6 +77,9 @@ main = do
         , Opts.command "ide"
             (Opts.info Ide.command
               (Opts.progDesc "Start or query an IDE server process"))
+        , Opts.command "lsp"
+            (Opts.info Lsp.command
+              (Opts.progDesc "Start or query an IDE server process using the Language Server Protocol"))
         , Opts.command "publish"
             (Opts.info Publish.command
               (Opts.progDesc "Generates documentation packages for upload to Pursuit"))