Initial LSP implementation/vscode support

src/Commands.newt

@@ -0,0 +1,49 @@
+-- For shared code between REPL and LSP
+module Commands
+
+import Prelude
+import Lib.ProcessModule
+import Lib.Types
+import Lib.TopContext
+import Lib.Common
+import Data.List1
+import Lib.Tokenizer
+import Lib.Token
+import Lib.Elab
+
+-- For now we cheat and assume capitalized directories are a module component
+decomposeName : String → String × List String
+decomposeName fn =
+    go Nil $ Lin <>< split (fst $ splitFileName fn) "/"
+    where
+        go : List String → SnocList String → String × List String
+        go acc Lin = (".", acc)
+        go acc (xs :< x) = if isUpper $ strIndex x 0
+            then go (x :: acc) xs
+            else (joinBy "/" (xs :< x <>> Nil), acc)
+
+-- The cheap version of type at point, find the token, lookup in global context
+-- Later we will either get good FC for entries or scan them all and build a cache.
+getHoverInfo : FileSource → List String → Int → Int → M (Maybe String)
+getHoverInfo repo modns row col = do
+    mod <- processModule emptyFC repo Nil modns
+    -- not necessarily loaded into top... (Maybe push this down into that branch of processModule)
+    modifyTop [ defs := mod.modDefs; metaCtx := mod.modMetaCtx; ops := mod.ctxOps; imported := mod.modDeps ]
+    top <- getTop
+
+    -- Find the token at the point
+    let lines = split mod.modSource "\n"
+    let line = fromMaybe "" (getAt' row lines)
+    let (Right toks) = tokenise "" line | Left _ => pure Nothing
+    let (Just name) = getTok toks       | _ => pure Nothing
+
+    -- Lookup the name
+    let (Just e) = lookupRaw name top   | _ => pure Nothing
+    pure $ Just "\{show e.name} : \{rpprint Nil e.type}"
+
+    where
+        getTok : List BTok → Maybe String
+        getTok Nil = Nothing
+        getTok (tok :: toks) =
+            if tok.bounds.startCol <= col && (col <= tok.bounds.endCol)
+            then Just $ value tok else getTok toks

src/LSP.newt

@@ -0,0 +1,144 @@
+module LSP
+
+import Prelude
+-- TODO pull this into its own file
+import Lib.Common
+import Lib.Types
+import Lib.TopContext
+import Lib.Tokenizer
+import Lib.Parser
+import Lib.Parser.Impl
+import Lib.ProcessModule
+import Data.SortedMap
+import Data.IORef
+import Node
+import Commands
+import Data.List1
+
+pfunc js_castArray : Array JSObject → JSObject := `x => x`
+pfunc js_castInt : Int → JSObject := `x => x`
+pfunc js_castBool : Bool → JSObject := `x => x`
+pfunc js_castStr : String → JSObject := `x => x`
+pfunc js_null : JSObject := `null`
+pfunc js_castObj : Array (String × JSObject) → JSObject := `(data) => {
+    let rval = {}
+    for (let x of data) rval[x.h2] = x.h3
+    return rval
+}`
+
+-- need case split
+jsonToJObject : Json → JSObject
+jsonToJObject (JsonInt x) = js_castInt x
+jsonToJObject (JsonNull) = js_null
+jsonToJObject (JsonArray xs) = js_castArray $ listToArray $ map jsonToJObject xs
+jsonToJObject (JsonBool x) = js_castBool x
+jsonToJObject (JsonStr x) = js_castStr x
+-- IMPERROR - if I leave off the `map` I get an error that is hard to sort out
+jsonToJObject (JsonObj xs) = js_castObj $ listToArray $ map (mapSnd jsonToJObject) xs
+
+record LSPState where
+    topContext : TopContext
+    baseDir : String
+    files : SortedMap String String
+
+state : IORef LSPState
+state = unsafePerformIO $ newIORef $ MkLSPState emptyTop "" emptyMap
+
+resetState : String → IO Unit
+resetState base = do
+    putStrLn "Reset base to \{base}"
+    writeIORef state $ MkLSPState emptyTop base emptyMap
+
+lspFileSource : FileSource
+lspFileSource = MkFileSource $ \fc fn => do
+    st <- readIORef state
+    let fn = st.baseDir ++ "/" ++ fn
+    let (Nothing) = lookupMap' fn st.files
+        | Just src => pure (fn,src)
+    let fn' = case split fn "file://" of
+        x :: fn :: _ => fn
+        _ => fn
+    (Right src) <- liftIO {M} $ readFile fn'
+        | Left err => throwError $ E fc "error reading \{fn}: \{show err}"
+    pure (fn,src)
+
+updateFile : String → String → Unit
+updateFile fn src = unsafePerformIO $ do
+    st <- readIORef state
+    modifyIORef state $ \a => [ files $= updateMap fn src ] a
+    let st = the LSPState $ [ files $= updateMap fn src ] st
+    -- module relative to base
+
+    let (Right toks) = tokenise fn src | Left err => writeIORef state st
+    let (Right ((nameFC, modName), _, _)) = partialParse fn parseModHeader emptyMap toks
+        | Left (err,toks) => writeIORef state st
+
+    Right (ctx,_) <- (invalidateModule $ split modName ".").runM st.topContext
+        | _ => writeIORef state st
+    -- TODO It doesn't have record type, but eta expanding resolves this.  See if there is a quick fix.
+    -- modifyIORef state [ topContext := ctx ]
+    modifyIORef state $ \a => [ topContext := ctx ] a
+
+hoverInfo : String → Int → Int → JSObject
+hoverInfo uri line col = unsafePerformIO $ do
+    let (base,modns) = decomposeName uri
+    putStrLn "Hover \{uri} base \{base} mod \{joinBy "." modns}"
+    st <- readIORef state
+    if (st.baseDir /= base)
+        then resetState base
+        else pure MkUnit
+    Right (_, Just msg) <- (getHoverInfo lspFileSource modns line col).runM st.topContext
+        | Right _  => do
+            putStrLn $ "Nothing to see here"
+            pure $ jsonToJObject JsonNull
+        | Left err => do
+            putStrLn $ showError "" err
+            pure $ jsonToJObject JsonNull
+    pure $ jsonToJObject $ JsonStr msg
+
+errorToDiag : Error -> Json
+errorToDiag (E (MkFC fn (MkBounds sr sc er ec)) msg) =
+  JsonObj
+    $  ("severity", JsonInt 1)
+    -- PARSER `$` is winning over `,`, which is not what I'm expecting  Maybe `,` should be special...
+    :: ("range", (JsonObj $ ("start", range sr sc) :: ("end", range er (ec + 1)) :: Nil))
+    :: ("message", JsonStr msg)
+    :: ("source", JsonStr "newt") -- what is this key for?
+    :: Nil
+  where
+    range : Int → Int → Json
+    range l c = JsonObj $ ("line", JsonInt l) :: ("character", JsonInt c) :: Nil
+-- These shouldn't escape
+errorToDiag (Postpone fc qn msg) = errorToDiag $ E fc "Postpone \{show qn} \{msg}"
+
+
+checkFile : String → JSObject
+checkFile fn = unsafePerformIO $ do
+    let (base,modns) = decomposeName fn
+    putStrLn "Checking \{fn} base \{base} mod \{joinBy "." modns}"
+    st <- readIORef state
+    if (st.baseDir /= base)
+        then resetState base
+        else pure MkUnit
+    (Right (top, json)) <- (do
+        modifyTop [ errors := Nil ]
+        putStrLn "add prim"
+        addPrimitives
+        putStrLn "processModule"
+        _ <- processModule emptyFC lspFileSource Nil modns
+        pure MkUnit
+        -- pull out errors and infos
+        top <- getTop
+        pure $ map (errorToDiag) top.errors
+        ).runM st.topContext
+        | Left err => do
+            putStrLn $ showError "" err
+            pure $ jsonToJObject $ JsonArray $ errorToDiag err :: Nil
+    -- Cache loaded modules
+    modifyIORef state $ \a => [ topContext := top ] a
+    pure $ jsonToJObject $ JsonArray json
+
+-- This seems like a hack, but it works.
+-- Dummy main function with references to force functions into ouput file.
+-- but we don't get `export` on it..
+pfunc main uses (updateFile checkFile hoverInfo) : IO Unit  := `() => {}`

src/Lib/Common.newt

@@ -81,6 +81,7 @@ data Json : U where
   JsonBool : Bool -> Json
   JsonInt : Int -> Json
   JsonArray : List Json -> Json
+  JsonNull : Json
 
 
 renderJson : Json -> String
@@ -88,6 +89,7 @@ renderJson (JsonObj xs) = "{" ++ joinBy "," (map renderPair xs) ++ "}"
   where
     renderPair : (String × Json) -> String
     renderPair (k,v) = quoteString k ++ ":" ++ renderJson v
+renderJson (JsonNull) = "null"
 renderJson (JsonStr str) = quoteString str
 renderJson (JsonBool x) = ite x "true" "false"
 renderJson (JsonInt i) = cast i

src/Lib/Elab.newt

@@ -27,6 +27,7 @@ collectDecl ((FunDef fc nm cl) :: rest@(FunDef _ nm' cl' :: xs)) =
   else (FunDef fc nm cl :: collectDecl rest)
 collectDecl (x :: xs) = x :: collectDecl xs
 
+-- TODO Move this, so we don't need to import all of Elab
 rpprint : List String → Tm → String
 rpprint names tm = render 90 $ pprint names tm
 

src/Lib/ProcessModule.newt

@@ -1,7 +1,6 @@
 module Lib.ProcessModule
 
 import Prelude
-import Serialize
 import Lib.Types
 import Lib.Common
 import Lib.Syntax
@@ -21,7 +20,14 @@ addPrimitives = do
   processDecl primNS (PType emptyFC "String" Nothing)
   processDecl primNS (PType emptyFC "Char" Nothing)
   setDef (QN primNS "PiType") emptyFC (Erased emptyFC) (PrimFn "(h0, h1) => ({ tag: \"PiType\", h0, h1 });" (S (S Z)) Nil) Nil
-
+  top <- getTop
+  let modules = updateMap primNS (MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops Nil) top.modules
+  modifyTop [ modules := modules
+      ; imported := primNS :: Nil
+      ; hints := emptyMap
+      ; ns := Nil
+      ; defs := emptyMap
+      ]
 
 record FileSource where
   getFile : FC → String → M (String × String)
@@ -31,7 +37,6 @@ parseDecls fn ops Nil acc = pure (acc <>> Nil, ops)
 parseDecls fn ops toks@(first :: _) acc =
   case partialParse fn (sameLevel parseDecl) ops toks of
     Left (err, toks) => do
-      putStrLn $ showError "" err
       addError err
       parseDecls fn ops (recover toks) acc
     Right (decl,ops,toks) => parseDecls fn ops toks (acc :< decl)
@@ -43,14 +48,6 @@ parseDecls fn ops toks@(first :: _) acc =
       then (tok :: toks)
       else recover toks
 
-moduleHash : String → List (List String) → M String
-moduleHash src imports = do
-  srcHash <- liftIO $ checksum src
-  top <- getTop
-  let mods = mapMaybe (\x => lookupMap' x top.modules) imports
-  let modHashes = map (\x => x.csum) mods
-  liftIO $ checksum $ fastConcat $ srcHash :: modHashes
-
 importToName : Import → List String
 importToName  (MkImport fc (_,name)) = split name "."
 
@@ -60,11 +57,14 @@ importHints (entry :: entries) = do
   when (elem Hint entry.eflags) $ \ _ => addHint entry.name
   importHints entries
 
-processModule : FC → FileSource → List String → List String → M String
+-- HACK this is returning src to help render errors..
+-- Maybe return module, put src and errors in module, add error for import with error, callers can sort out what they want to do?
+-- The issue here is command line newt wants to report all errors (we can print that though?)  LSP wants something more subtle
+processModule : FC → FileSource → List String → (stack : List String) → M ModContext
 processModule importFC repo stk modns = do
   top <- getTop
   let name = joinBy "." modns
-  let (Nothing) = lookupMap modns top.modules | _ => pure ""
+  let (Nothing) = lookupMap' modns top.modules | Just mod => pure mod
 
   let fn = joinBy "/" modns ++ ".newt"
   -- TODO now we can pass in the module name...
@@ -91,21 +91,8 @@ processModule importFC repo stk modns = do
       processModule nameFC repo (name :: stk) imp
       pure $ imp
   let imported = snoc imported primNS
-  srcSum <- liftIO $ checksum src
-  csum <- moduleHash srcSum imported
 
   putStrLn "module \{modName}"
-  top <- getTop
-  -- TODO we need a flag on this so `make newt3.js` properly tests self-compile
-  (Nothing) <- loadModule modns csum
-    | Just mod => do
-      let modules = updateMap modns mod top.modules
-
-      -- FIXME - we don't want stray operators in a module.
-      -- inject module ops into top
-      let ops = foldMap const top.ops $ toList mod.ctxOps
-      modifyTop [modules := modules; ops := ops ]
-      pure src  -- why am I returning this?
 
   log 1 $ \ _ => "MODNS " ++ show modns
   top <- getTop
@@ -131,21 +118,20 @@ processModule importFC repo stk modns = do
   -- update modules with result, leave the rest of context in case this is top file
   top <- getTop
 
-  let mod = MkModCtx csum top.defs top.metaCtx top.ops importNames
-  if stk /= Nil && length' top.errors == 0
-    then dumpModule modns src mod
-    else pure MkUnit
+  let mod = MkModCtx src top.defs top.metaCtx top.ops importNames
 
   let modules = updateMap modns mod top.modules
   modifyTop [modules := modules]
 
   logMetas $ reverse $ listValues top.metaCtx.metas
-  let (Nil) = top.errors
-    | errors => throwError $ E importFC "Failed to compile module \{joinBy "." modns}"
-  pure src
+  -- FIXME module context should hold errors, to report in replay
+  pure mod
   where
     tryProcessDecl : String → List String → Decl → M Unit
     tryProcessDecl src ns decl = do
       (Left err) <- tryError $ processDecl ns decl | _ => pure MkUnit
-      putStrLn $ showError src err
       addError err
+
+-- TODO clear dependents too.
+invalidateModule : List String -> M Unit
+invalidateModule modname = modifyTop [modules $= deleteMap modname]

src/Lib/TopContext.newt

@@ -46,11 +46,8 @@ lookupRaw raw top =
 instance Show TopContext where
   show top = "\nContext:\n [\{ joinBy "\n" $ map (show ∘ snd) $ toList top.defs}]"
 
--- TODO need to get class dependencies working
-emptyTop : ∀ io. {{Monad io}} {{HasIO io}} -> io TopContext
-emptyTop = do
-  let mcctx = MC emptyMap Nil 0 CheckAll
-  pure $ MkTop emptyMap Nil emptyMap Nil emptyMap mcctx 0 Nil emptyMap
+emptyTop : TopContext
+emptyTop = MkTop emptyMap Nil emptyMap Nil emptyMap (MC emptyMap Nil 0 CheckAll) 0 Nil emptyMap
 
 
 setFlag : QName → FC → EFlag → M Unit

src/Lib/Types.newt

@@ -396,7 +396,7 @@ instance Show TopEntry where
 
 record ModContext where
   constructor MkModCtx
-  csum : String
+  modSource : String
   modDefs : SortedMap QName TopEntry
   -- Do we need this if everything solved is zonked?
   modMetaCtx : MetaContext

src/Main.newt

@@ -18,7 +18,6 @@ import Lib.Types
 import Lib.Syntax
 import Lib.ReplParser
 import Node
-import Serialize
 import Revision
 
 dirFileSource : String → FileSource
@@ -73,8 +72,7 @@ showErrors fn src = do
         throwError $ E (MkFC fn $ MkBounds 0 0 0 0) "Compile failed"
   pure MkUnit
 
-invalidateModule : List String -> M Unit
-invalidateModule modname = modifyTop [modules $= deleteMap modname]
+
 
 -- processFile called on the top level file
 -- it sets up everything and then recurses into processModule
@@ -98,21 +96,12 @@ processFile fn = do
   base <- getBaseDir fn nameFC modns
   addPrimitives
 
-  top <- getTop
-  let modules = updateMap primNS (MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops Nil) top.modules
-  modifyTop [ modules := modules
-            ; imported := primNS :: Nil
-            ; hints := emptyMap
-            ; ns := Nil
-            ; defs := emptyMap
-            ]
-
   invalidateModule modns
   let repo = dirFileSource base
-  src <- processModule emptyFC repo Nil modns
+  mod <- processModule emptyFC repo Nil modns
   top <- getTop
 
-  showErrors fn src
+  showErrors fn mod.modSource
   pure MkUnit
 
 cmdLine : List String -> M (Maybe String × List String)
@@ -142,7 +131,7 @@ browseTop qn@(QN ns x) = do
     go : List TopEntry → M Unit
     go Nil = pure MkUnit
     go (e :: es) = do
-      putStrLn "\{show e.name} : \{rpprint Nil e.type}"
+      putStrLn "\{show e.fc} \{show e.name} : \{rpprint Nil e.type}"
       go es
 
 replHeader : M Unit
@@ -206,6 +195,7 @@ main' = do
             replHeader
             runRepl
   (out, files) <- cmdLine args
+
   traverse processFile files
 
   when (elem "--top" args) $ \ _ => do
@@ -218,8 +208,6 @@ main' = do
 
 main : IO Unit
 main = do
-  -- we'll need to reset for each file, etc.
-  ctx <- emptyTop
-  (Right _)  <- .runM main' ctx
+  (Right _)  <- .runM main' emptyTop
     | Left err => exitFailure "ERROR at \{show $ getFC err}: \{errorMsg err}"
   putStrLn "done"

src/Prelude.newt

@@ -954,4 +954,5 @@ pfunc fatalError : ∀ a. String → a := `(_, msg) => { throw new Error(msg) }`
 foldlM : ∀ m a e. {{Monad m}} → (a → e → m a) → a → List e → m a
 foldlM f a xs = foldl (\ ma b => ma >>= flip f b) (pure a) xs
 
-pfunc unsafePerformIO : ∀ a. IO a → a := `(a, f) => f().h1`
+pfunc unsafePerformIO : ∀ a. IO a → a := `(a, f) => f().h1 `
+