add jump to def and type on hover for top level

TODO.md

@@ -17,18 +17,24 @@
 - [ ] if we're staying with this version of auto, we might need to list candidates and why they're rejected. e.g. I had a bifunctor fail to solve because the right answer unblocked a Foo vs IO Foo mismatch
 - [ ] literals for double
 - [ ] add default failing case for constructor matching to catch errors
-- [x] Add icit to Lam (see `check` for details)
-  - [ ] make change to `check` NOW
+- [x] Add icit to Lam
 - [ ] add jump to definition magic to vscode extension
+  - [x] Cheap dump to def - dump context
 - [ ] TCO? Probably needed in browser, since v8 doesn't do it. bun and JavaScriptCore do support it.
 - [x] deconstructing `let` (and do arrows)
 - [x] Fix string printing to be js instead of weird Idris strings
 - [x] make $ special
   - Makes inference easier, cleaner output, and allows `foo $ \ x => ...`
   - remove hack from Elab.infer
-  - [ ] `$` no longer works inside ≡⟨ ⟩ sort out how to support both that and `$ \ x => ...`
+  - [ ] `$` no longer works inside ≡⟨ ⟩ sort out how to support both that and `$ \ x => ...` (or don't bother)
+- [ ] **Translate newt to newt**
   - [ ] Support @ on the LHS
+  - [x] if / then / else sugar
+  - [ ] `data Foo = A | B` sugar
   - [ ] records
+  - [x] where
+  - [ ] add namespaces
+  - [ ] magic nat?
 - [ ] rework `unify` case tree
   - Idris needs help with the case tree to keep code size down, do it in stages, one dcon at a time.
   - I'm not sure it can go a few steps deep and have a default hanging off the side, so we may need to put the default case in another function ourselves.
@@ -39,7 +45,6 @@
 - [x] add filenames to FC
 - [ ] Add full ranges to FC
 - [x] maybe use backtick for javascript so we don't highlight strings as JS
-- [ ] add namespaces
 - [x] dead code elimination
 - [x] imported files leak info messages everywhere
   - For now, take the start ix for the file and report at end starting there
@@ -60,8 +65,7 @@
     we have different core terms for TCon/DCon/Function
 - [ ] Require infix decl before declaring names with `_` (helps find bugs)
 - [x] sugar for typeclasses
-- [ ] maybe add implicits in core to help resugar operators?
-  - There is also a bit where kovacs uses the implicit on the type (a value) to decide to insert
+- [x] maybe add implicits in core to help resugar operators?
 - [ ] consider binders in environment, like Idris, to better mark `let` and to provide names
 - [x] move some top-level chattiness to `debug`
 - [ ] consider optionally compiling to eliminators for a second type-checking pass to help catch bugs.
@@ -70,7 +74,7 @@
   - [x] editor
   - [x] view output
   - [x] view javascript
-  - [ ] run javascript
+  - [x] run javascript
   - [x] need to shim out Buffer
 - [x] get rid of stray INFO from auto resolution
 - [x] handle `if_then_else_` style mixfix
@@ -88,14 +92,6 @@
   - [x] day1
   - [x] day2 - day6
   - some "real world" examples
-- [ ] Translate newt to newt
-  - [x] Prettier
-  - [x] if / then / else sugar
-  - [ ] `data Foo = A | B` sugar
-  - [ ] records
-  - [x] where
-  - [ ] namespaces
-  - [ ] magic nat?
 - [x] Maybe Eq and stuff would work for typeclass without dealing with unification issues yet
 - [x] unsolved meta errors repeat (need to freeze or only report at end)
 - [x] Sanitize JS idents, e.g. `_+_`
@@ -137,10 +133,10 @@
   - I'm going to try explicit annotation, forall/∀ is erased
   - [x] Parser side
   - [x] push down to value/term
-  - [ ] check quantity!!
+  - [x] check quantity
   - [x] erase in output
   - [ ] remove erased top level arguments
-- [ ] type at point in vscode
+- [ ] type at point in vscode NOW
 - [ ] repl
 - [ ] LSP
 - [x] don't match forced constructors at runtime

newt-vscode/src/extension.ts

@@ -2,7 +2,23 @@ import * as vscode from "vscode";
 import { exec } from "child_process";
 import path from "path";
 
+interface FC {
+  file: string;
+  line: number;
+  col: number;
+}
+
+interface TopEntry {
+  fc: FC;
+  name: String;
+  type: String;
+}
+interface TopData {
+  context: TopEntry[];
+}
+
 export function activate(context: vscode.ExtensionContext) {
+  let topData: undefined | TopData;
   const diagnosticCollection =
     vscode.languages.createDiagnosticCollection("newt");
 
@@ -15,8 +31,11 @@ export function activate(context: vscode.ExtensionContext) {
       : path.dirname(fileName);
     const config = vscode.workspace.getConfiguration("newt");
     const cmd = config.get<string>("path", "build/exec/newt");
-    const command = `${cmd} ${fileName}`;
-    exec(command, { cwd, maxBuffer: 1024*1024*10 }, (err, stdout, _stderr) => {
+    const command = `${cmd} --top ${fileName}`;
+    exec(
+      command,
+      { cwd, maxBuffer: 1024 * 1024 * 10 },
+      (err, stdout, _stderr) => {
         // I think I ignored 1 here because I wanted failure to launch
         if (err && err.code !== 1) {
           vscode.window.showErrorMessage(`newt error: ${err}`);
@@ -29,22 +48,40 @@ export function activate(context: vscode.ExtensionContext) {
         if (err) {
           let start = new vscode.Position(0, 0);
           let end = new vscode.Position(0, 1);
-        let range = document.getWordRangeAtPosition(start) ?? new vscode.Range(start,end);
-        const diag = new vscode.Diagnostic(range, "newt execution failed", vscode.DiagnosticSeverity.Error);
+          let range =
+            document.getWordRangeAtPosition(start) ??
+            new vscode.Range(start, end);
+          const diag = new vscode.Diagnostic(
+            range,
+            "newt execution failed",
+            vscode.DiagnosticSeverity.Error
+          );
           diagnostics.push(diag);
         }
 
         for (let i = 0; i < lines.length; i++) {
           const line = lines[i];
-        const match = line.match(/(INFO|ERROR) at (.*):\((\d+), (\d+)\):\s*(.*)/);
+          if (line.startsWith("TOP:")) {
+            try {
+              topData = JSON.parse(line.slice(4));
+            } catch (e) {
+              console.error("Bad top data", e);
+            }
+            console.log("top data", topData);
+          }
+          const match = line.match(
+            /(INFO|ERROR) at (.*):\((\d+), (\d+)\):\s*(.*)/
+          );
           if (match) {
             let [_full, kind, file, line, column, message] = match;
             // FIXME - check filename against current
-          console.log('********', file, fileName);
+            console.log("********", file, fileName);
 
             let lnum = Number(line);
             let cnum = Number(column);
-          if (file !== fileName) { lnum = cnum = 0; }
+            if (file !== fileName) {
+              lnum = cnum = 0;
+            }
             let start = new vscode.Position(lnum, cnum);
             // we don't have the full range, so grab the surrounding word
             let end = new vscode.Position(lnum, cnum + 1);
@@ -55,18 +92,22 @@ export function activate(context: vscode.ExtensionContext) {
             // anything indented
             // Context:, or Goal: are part of PRINTME
             // unexpected / expecting appear in parse errors
-          while (
-            lines[i + 1]?.match(/^(  )/)
-          ) {
+            while (lines[i + 1]?.match(/^(  )/)) {
               message += "\n" + lines[++i];
             }
-          const severity = kind === 'ERROR' ? vscode.DiagnosticSeverity.Error : vscode.DiagnosticSeverity.Information;
+            const severity =
+              kind === "ERROR"
+                ? vscode.DiagnosticSeverity.Error
+                : vscode.DiagnosticSeverity.Information;
             const diag = new vscode.Diagnostic(range, message, severity);
-          if (kind === 'ERROR' || lnum > 0) { diagnostics.push(diag); }
+            if (kind === "ERROR" || lnum > 0) {
+              diagnostics.push(diag);
+            }
           }
         }
         diagnosticCollection.set(vscode.Uri.file(fileName), diagnostics);
-    });
+      }
+    );
   }
 
   const runPiForall = vscode.commands.registerCommand(
@@ -81,6 +122,50 @@ export function activate(context: vscode.ExtensionContext) {
       }
     }
   );
+
+  context.subscriptions.push(
+    vscode.languages.registerDefinitionProvider(
+      { language: "newt" },
+      {
+        provideDefinition(document, position, cancelToken) {
+          if (!topData) return null;
+          const wordRange = document.getWordRangeAtPosition(position);
+          if (!wordRange) return null;
+          const name = document.getText(wordRange);
+          let entry = topData.context.find((entry) => entry.name === name);
+          if (!entry) {
+            console.log(`entry ${name} not found`);
+            return null;
+          }
+          let uri = vscode.Uri.file(entry.fc.file);
+          let start = new vscode.Position(entry.fc.line, entry.fc.col);
+          let range = new vscode.Range(start, start);
+          return new vscode.Location(uri, range);
+        },
+      }
+    )
+  );
+
+  context.subscriptions.push(
+    vscode.languages.registerHoverProvider(
+      {language: 'newt'},
+      {
+        provideHover(document, position, token) {
+          if (!topData) return null;
+          const wordRange = document.getWordRangeAtPosition(position);
+          if (!wordRange) return null;
+          const name = document.getText(wordRange);
+          let entry = topData.context.find((entry) => entry.name === name);
+          if (!entry) {
+            console.log(`entry ${name} not found`);
+            return null;
+          }
+          return new vscode.Hover(`${entry.name} : ${entry.type}`);
+        }
+      }
+    )
+  )
+
   context.subscriptions.push(runPiForall);
 
   vscode.workspace.onDidSaveTextDocument((document) => {

playground/src/main.ts

@@ -5,20 +5,78 @@ import { useEffect, useRef, useState } from "preact/hooks";
 import { h, render, VNode } from "preact";
 import { ChangeEvent } from "preact/compat";
 
+interface FC {
+  file: string;
+  line: number;
+  col: number;
+}
+
+interface TopEntry {
+  fc: FC;
+  name: String;
+  type: String;
+}
+interface TopData {
+  context: TopEntry[];
+}
+
+let topData: undefined | TopData;
+
+// we need to fix the definition of word
 monaco.languages.register({ id: "newt" });
 monaco.languages.setMonarchTokensProvider("newt", newtTokens);
 monaco.languages.setLanguageConfiguration("newt", newtConfig);
+monaco.languages.registerDefinitionProvider("newt", {
+  provideDefinition(model, position, token) {
+    if (!topData) return;
+    // HACK - we don't know our filename which was generated from `module` decl, so
+    // assume the last context entry is in our file.
+    let last = topData.context[topData.context.length-1]
+    let file = last.fc.file
 
+    const info = model.getWordAtPosition(position);
+    if (!info) return;
+    let entry = topData.context.find((entry) => entry.name === info.word);
+    // we can't switch files at the moment
+    if (!entry || entry.fc.file !== file) return
+    let lineNumber = entry.fc.line + 1
+    let column = entry.fc.col + 1
+    let word = model.getWordAtPosition({lineNumber, column})
+    let range = new monaco.Range(lineNumber, column, lineNumber, column)
+    if (word) {
+      range = new monaco.Range(lineNumber, word.startColumn, lineNumber, word.endColumn)
+    }
+    return { uri: model.uri,range}
+  },
+});
+monaco.languages.registerHoverProvider("newt", {
+  provideHover(model, position, token, context) {
+    if (!topData) return;
+    const info = model.getWordAtPosition(position);
+    if (!info) return;
+    let entry = topData.context.find((entry) => entry.name === info.word);
+    if (!entry) return;
+    return {
+      range: new monaco.Range(
+        position.lineNumber,
+        info.startColumn,
+        position.lineNumber,
+        info.endColumn
+      ),
+      contents: [{ value: `${entry.name} : ${entry.type}` }],
+    };
+  },
+});
 const newtWorker = new Worker("worker.js");
-let postMessage = (msg: any) => newtWorker.postMessage(msg)
+let postMessage = (msg: any) => newtWorker.postMessage(msg);
 
 // Safari/MobileSafari have small stacks in webworkers.
-if (navigator.vendor.includes('Apple')) {
+if (navigator.vendor.includes("Apple")) {
   const workerFrame = document.createElement("iframe");
-  workerFrame.src = "worker.html"
-  workerFrame.style.display = "none"
-  document.body.appendChild(workerFrame)
-  postMessage = (msg: any) => workerFrame.contentWindow?.postMessage(msg, '*')
+  workerFrame.src = "worker.html";
+  workerFrame.style.display = "none";
+  document.body.appendChild(workerFrame);
+  postMessage = (msg: any) => workerFrame.contentWindow?.postMessage(msg, "*");
 }
 
 // iframe for running newt output
@@ -28,8 +86,8 @@ iframe.style.display = "none";
 document.body.appendChild(iframe);
 
 function run(src: string) {
-  console.log('SEND TO', iframe.contentWindow)
-  postMessage({src})
+  console.log("SEND TO", iframe.contentWindow);
+  postMessage({ src });
 }
 
 function runOutput() {
@@ -42,21 +100,38 @@ function runOutput() {
   }
 }
 
+function setOutput(output: string) {
+  let lines = output.split("\n");
+  output = lines.filter((l) => !l.startsWith("TOP:")).join("\n");
+  let data = lines.find((l) => l.startsWith("TOP:"));
+  if (data) {
+    try {
+      topData = JSON.parse(data.slice(4));
+      console.log({ topData });
+    } catch (e) {
+      console.error(e);
+    }
+  } else {
+    topData = undefined;
+  }
+  state.output.value = output;
+}
+
 window.onmessage = (ev) => {
   console.log("window got", ev.data);
   if (ev.data.messages) state.messages.value = ev.data.messages;
   if (ev.data.message) {
-    state.messages.value = [...state.messages.value, ev.data.message]
+    state.messages.value = [...state.messages.value, ev.data.message];
   }
   // safari callback
   if (ev.data.output !== undefined) {
-    state.output.value = ev.data.output;
+    setOutput(ev.data.output);
     state.javascript.value = ev.data.javascript;
   }
 };
 
 newtWorker.onmessage = (ev) => {
-  state.output.value = ev.data.output;
+  setOutput(ev.data.output);
   state.javascript.value = ev.data.javascript;
 };
 
@@ -310,9 +385,9 @@ const processOutput = (
   let model = editor.getModel()!;
   let markers: monaco.editor.IMarkerData[] = [];
   let lines = output.split("\n");
-  let m = lines[0].match(/.*Process (.*)/)
-  let fn = ''
-  if (m) fn = m[1]
+  let m = lines[0].match(/.*Process (.*)/);
+  let fn = "";
+  if (m) fn = m[1];
   for (let i = 0; i < lines.length; i++) {
     const line = lines[i];
     const match = line.match(/(INFO|ERROR) at (.*):\((\d+), (\d+)\):\s*(.*)/);
@@ -321,7 +396,7 @@ const processOutput = (
       let lineNumber = +line + 1;
       let column = +col + 1;
       if (fn && file !== fn) {
-        lineNumber = column = 0
+        lineNumber = column = 0;
       }
       let start = { column, lineNumber };
       // we don't have the full range, so grab the surrounding word
@@ -340,7 +415,7 @@ const processOutput = (
         kind === "ERROR"
           ? monaco.MarkerSeverity.Error
           : monaco.MarkerSeverity.Info;
-      if (kind === 'ERROR' || lineNumber)
+      if (kind === "ERROR" || lineNumber)
         markers.push({
           severity,
           message,

playground/src/worker.ts

@@ -139,7 +139,7 @@ const handleMessage = async function (e) {
   let m = src.match(/module (\w+)/)
   if (m) module = m[1]
   let fn = `${module}.newt`
-  process.argv = ["", "", fn, "-o", "out.js"];
+  process.argv = ["", "", fn, "-o", "out.js", "--top"];
   console.log("args", process.argv);
   files[fn] = src;
   files['out.js'] = 'No JS output';

src/Lib/Common.idr

@@ -1,8 +1,72 @@
 module Lib.Common
 
 import Data.String
+import Data.Nat
+import Data.Maybe
 import public Data.SortedMap
 
+hexChars : List Char
+hexChars = unpack "0123456789ABCDEF"
+
+-- export
+hexDigit : Nat -> Char
+hexDigit v = fromMaybe ' ' (getAt (mod v 16) hexChars)
+
+export
+toHex : Nat -> List Char
+toHex 0 = []
+toHex v = snoc (toHex (div v 16)) (hexDigit v)
+
+export
+quoteString : String -> String
+quoteString str = pack $ encode (unpack str) [< '"']
+  where
+    encode : List Char -> SnocList Char -> List Char
+    encode [] acc = acc <>> ['"']
+    encode ('"' :: cs) acc = encode cs (acc :< '\\' :< '"')
+    encode ('\n' :: cs) acc = encode cs (acc :< '\\' :< 'n')
+    encode ('\\' :: cs) acc = encode cs (acc :< '\\' :< '\\')
+    encode (c :: cs) acc =
+      let v : Nat = cast c in
+      if v < 32 then encode cs (acc :< '\\' :< 'u' :< hexDigit (div v 4096) :< hexDigit (div v 256) :< hexDigit (div v 16) :< hexDigit v )
+      else encode cs (acc :< c)
+      -- else if v < 128 then encode cs (acc :< c)
+      -- if v < 32 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
+      -- else if v < 128 then encode cs (acc :< c)
+      -- -- TODO unicode
+      -- else if v < 256 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
+      -- else encode cs (acc :< '\\' :< 'u' :< hexDigit (div v 4096) :< hexDigit (div v 256) :< hexDigit (div v 16) :< hexDigit v )
+
+public export
+data Json : Type where
+  JsonObj : List (String, Json) -> Json
+  JsonStr : String -> Json
+  JsonBool : Bool -> Json
+  JsonInt : Int -> Json
+  JsonArray : List Json -> Json
+
+export
+renderJson : Json -> String
+renderJson (JsonObj xs) = "{" ++ joinBy "," (map renderPair xs) ++ "}"
+  where
+    renderPair : (String,Json) -> String
+    renderPair (k,v) = quoteString k ++ ":" ++ renderJson v
+renderJson (JsonStr str) = quoteString str
+renderJson (JsonBool x) = ifThenElse x "true" "false"
+renderJson (JsonInt i) = cast i
+renderJson (JsonArray xs) = "[" ++ joinBy "," (map renderJson xs) ++ "]"
+
+public export
+interface ToJSON a where
+  toJson : a -> Json
+
+export
+ToJSON String where
+  toJson = JsonStr
+
+export
+ToJSON Int where
+  toJson = JsonInt
 
 public export
 record FC where
@@ -10,6 +74,10 @@ record FC where
   file : String
   start : (Int,Int)
 
+export
+ToJSON FC where
+  toJson (MkFC file (line,col)) = JsonObj [ ("file", toJson file), ("line", toJson line), ("col", toJson col)]
+
 export
 (.line) : FC -> Int
 fc.line = fst fc.start

src/Lib/Compile.idr

@@ -171,33 +171,6 @@ termToJS env (CCase t alts) f =
     maybeCaseStmt env nm alts =
           (JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
 
-chars : List Char
-chars = unpack "0123456789ABCDEF"
-
-hexDigit : Nat -> Char
-hexDigit v = fromMaybe ' ' (getAt (mod v 16) chars)
-
-toHex : Nat -> List Char
-toHex 0 = []
-toHex v = snoc (toHex (div v 16)) (hexDigit v)
-
--- FIXME escaping is wrong, e.g. \215 instead of \xd7
-jsString : String -> Doc
-jsString str = text $ pack $ encode (unpack str) [< '"']
-  where
-    encode : List Char -> SnocList Char -> List Char
-    encode [] acc = acc <>> ['"']
-    encode ('"' :: cs) acc = encode cs (acc :< '\\' :< '"')
-    encode ('\n' :: cs) acc = encode cs (acc :< '\\' :< 'n')
-    encode ('\\' :: cs) acc = encode cs (acc :< '\\' :< '\\')
-    encode (c :: cs) acc =
-      let v : Nat = cast c in
-      if v < 32 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
-      else if v < 128 then encode cs (acc :< c)
-      -- TODO unicode
-      else if v < 256 then encode cs (acc :< '\\' :< 'x' :< hexDigit (div v 16) :< hexDigit v )
-      else encode cs (acc :< '\\' :< 'u' :< hexDigit (div v 4096) :< hexDigit (div v 256) :< hexDigit (div v 16) :< hexDigit v )
-
 keywords : List String
 keywords = [
   "var", "true", "false", "let", "case", "switch", "if", "then", "else", "String",
@@ -232,7 +205,7 @@ expToDoc (LitObject xs) = text "{" <+> folddoc (\ a, e => a ++ ", " <+/> e) (map
     -- TODO quote if needed
     entry (nm, exp) = jsIdent nm ++ ":" <+> expToDoc exp
 
-expToDoc (LitString str) = jsString str
+expToDoc (LitString str) = text $ quoteString str
 expToDoc (LitInt i) = text $ show i
 -- TODO add precedence
 expToDoc (Apply x@(JLam{}) xs) = text "(" ++ expToDoc x ++ ")" ++ "(" ++ nest 2 (commaSep (map expToDoc xs)) ++ ")"
@@ -251,7 +224,7 @@ caseBody {e} stmt@(JCase{}) = nest 2 (line ++ stmtToDoc stmt </> text "break;")
 caseBody stmt = line ++ "{" ++ nest 2 (line ++ stmtToDoc stmt </> text "break;") </> "}"
 
 altToDoc : JAlt -> Doc
-altToDoc (JConAlt nm stmt) = text "case" <+> jsString nm ++ ":" ++ caseBody stmt
+altToDoc (JConAlt nm stmt) = text "case" <+> text (quoteString nm) ++ ":" ++ caseBody stmt
 altToDoc (JDefAlt stmt) = text "default" ++ ":" ++ caseBody stmt
 altToDoc (JLitAlt a stmt) = text "case" <+> expToDoc a ++ ":" ++ caseBody stmt
 
@@ -262,7 +235,7 @@ stmtToDoc (JLet nm body) = "let" <+> jsIdent nm ++ ";" </> stmtToDoc body
 stmtToDoc (JAssign nm expr) = jsIdent nm <+> "=" <+> expToDoc expr ++ ";"
 stmtToDoc (JConst nm x) = text "const" <+> jsIdent nm <+> nest 2 ("=" <+/> expToDoc x ++ ";")
 stmtToDoc (JReturn x) = text "return" <+> expToDoc x ++ ";"
-stmtToDoc (JError str) = text "throw new Error(" ++ jsString str ++ ");"
+stmtToDoc (JError str) = text "throw new Error(" ++ text (quoteString str) ++ ");"
 stmtToDoc (JCase sc alts) =
   text "switch (" ++ expToDoc sc ++ ")" <+> bracket "{" (stack $ map altToDoc alts) "}"
 
@@ -283,16 +256,16 @@ maybeWrap (JReturn exp) = exp
 maybeWrap stmt = Apply (JLam [] stmt) []
 
 entryToDoc : TopEntry -> M Doc
-entryToDoc (MkEntry name ty (Fn tm)) = do
+entryToDoc (MkEntry _ name ty (Fn tm)) = do
   debug "compileFun \{pprint [] tm}"
   ct <- compileFun tm
   let exp = maybeWrap $ termToJS empty ct JReturn
   pure $ text "const" <+> jsIdent name <+> text "=" <+/> expToDoc exp ++ ";"
-entryToDoc (MkEntry name type Axiom) = pure ""
-entryToDoc (MkEntry name type (TCon strs)) = pure $ dcon name (piArity type)
-entryToDoc (MkEntry name type (DCon arity str)) = pure $ dcon name arity
-entryToDoc (MkEntry name type PrimTCon) = pure $ dcon name (piArity type)
-entryToDoc (MkEntry name _ (PrimFn src _)) = pure $ text "const" <+> jsIdent name <+> "=" <+> text src
+entryToDoc (MkEntry _ name type Axiom) = pure ""
+entryToDoc (MkEntry _ name type (TCon strs)) = pure $ dcon name (piArity type)
+entryToDoc (MkEntry _ name type (DCon arity str)) = pure $ dcon name arity
+entryToDoc (MkEntry _ name type PrimTCon) = pure $ dcon name (piArity type)
+entryToDoc (MkEntry _ name _ (PrimFn src _)) = pure $ text "const" <+> jsIdent name <+> "=" <+> text src
 
 ||| This version (call `reverse . snd <$> process "main" ([],[])`) will do dead
 ||| code elimination, but the Prelude js primitives are reaching for
@@ -303,10 +276,10 @@ process (done,docs) nm = do
   top <- get
   case TopContext.lookup nm top of
     Nothing => error emptyFC "\{nm} not in scope"
-    Just entry@(MkEntry name ty (PrimFn src uses)) => do
+    Just entry@(MkEntry _ name ty (PrimFn src uses)) => do
       (done,docs) <- foldlM process (nm :: done, docs) uses
       pure (done, !(entryToDoc entry) :: docs)
-    Just (MkEntry name ty (Fn tm)) => do
+    Just (MkEntry _ name ty (Fn tm)) => do
                 debug "compileFun \{pprint [] tm}"
                 ct <- compileFun tm
                 -- If ct has zero arity and is a compount expression, this fails..

src/Lib/CompileExp.idr

@@ -62,13 +62,13 @@ arityForName : FC -> Name -> M Nat
 arityForName fc nm = case lookup nm !get of
   -- let the magic hole through for now (will generate bad JS)
   Nothing => error fc "Name \{show nm} not in scope"
-  (Just (MkEntry name type Axiom)) => pure 0
-  (Just (MkEntry name type (TCon strs))) => pure $ piArity type
-  (Just (MkEntry name type (DCon k str))) => pure k
-  (Just (MkEntry name type (Fn t))) => pure $ lamArity t
-  (Just (MkEntry name type (PrimTCon))) => pure $ piArity type
+  (Just (MkEntry _ name type Axiom)) => pure 0
+  (Just (MkEntry _ name type (TCon strs))) => pure $ piArity type
+  (Just (MkEntry _ name type (DCon k str))) => pure k
+  (Just (MkEntry _ name type (Fn t))) => pure $ lamArity t
+  (Just (MkEntry _ name type (PrimTCon))) => pure $ piArity type
   -- Assuming a primitive can't return a function
-  (Just (MkEntry name type (PrimFn t uses))) => pure $ piArity type
+  (Just (MkEntry _ name type (PrimFn t uses))) => pure $ piArity type
 
 export
 compileTerm : Tm -> M CExp
@@ -109,7 +109,7 @@ compileTerm (Bnd _ k) = pure $ CBnd k
 -- need to eta expand to arity
 compileTerm t@(Ref fc nm _) = do
   top <- get
-  let Just (MkEntry _ type _) = lookup nm top
+  let Just (MkEntry _ _ type _) = lookup nm top
           | Nothing => error fc "Undefined name \{nm}"
   apply (CRef nm) [] [<] !(arityForName fc nm) type
 
@@ -123,7 +123,7 @@ compileTerm tm@(App _ _ _) with (funArgs tm)
         args' <- traverse compileTerm args
         arity <- arityForName fc nm
         top <- get
-        let Just (MkEntry _ type _) = lookup nm top
+        let Just (MkEntry _ _ type _) = lookup nm top
           | Nothing => error fc "Undefined name \{nm}"
         apply (CRef nm) args' [<] arity type
   _ | (t, args) = do

src/Lib/Elab.idr

@@ -331,13 +331,13 @@ unify env mode t u = do
     unify' t         u@(VRef fc' k' def sp') = do
       debug "expand \{show t} =?= %ref \{k'}"
       case lookup k' !(get) of
-        Just (MkEntry name ty (Fn tm)) => unify env mode t !(vappSpine !(eval [] CBN tm) sp')
+        Just (MkEntry _ name ty (Fn tm)) => unify env mode t !(vappSpine !(eval [] CBN tm) sp')
         _ => error fc' "unify failed \{show t} =?= \{show u} [no Fn]\n  env is \{show env}"
 
     unify' t@(VRef fc k def sp) u = do
       debug "expand %ref \{k} \{show sp} =?= \{show u}"
       case lookup k !(get) of
-        Just (MkEntry name ty (Fn tm)) => unify env mode !(vappSpine !(eval [] CBN tm) sp) u
+        Just (MkEntry _ name ty (Fn tm)) => unify env mode !(vappSpine !(eval [] CBN tm) sp) u
         _ => error fc "unify failed \{show t} [no Fn] =?= \{show u}\n  env is \{show env}"
 
     -- REVIEW I'd like to quote this back, but we have l that aren't in the environment.
@@ -397,7 +397,7 @@ insert ctx tm ty = do
 
 primType : FC -> String -> M Val
 primType fc nm = case lookup nm !(get) of
-      Just (MkEntry name ty PrimTCon) => pure $ VRef fc name PrimTCon [<]
+      Just (MkEntry _ name ty PrimTCon) => pure $ VRef fc name PrimTCon [<]
       _ => error fc "Primitive type \{show nm} not in scope"
 
 export
@@ -470,12 +470,12 @@ getConstructors ctx scfc (VRef fc nm _ _) = do
   where
     lookupTCon : String -> M (List String)
     lookupTCon str = case lookup nm !get of
-        (Just (MkEntry name type (TCon names))) => pure names
+        (Just (MkEntry _ name type (TCon names))) => pure names
         _ => error scfc "Not a type constructor \{nm}"
     lookupDCon : String -> M (String, Nat, Tm)
     lookupDCon nm = do
       case lookup nm !get of
-        (Just (MkEntry name type (DCon k str))) => pure (name, k, type)
+        (Just (MkEntry _ name type (DCon k str))) => pure (name, k, type)
         Just _ => error fc "Internal Error: \{nm} is not a DCon"
         Nothing => error fc "Internal Error: DCon \{nm} not found"
 getConstructors ctx scfc tm = error scfc "Can't split - not VRef: \{!(pprint ctx tm)}"
@@ -676,7 +676,7 @@ mkPat : TopContext -> (Raw, Icit) -> M Pattern
 mkPat top (tm, icit) = do
   case splitArgs tm [] of
     ((RVar fc nm), b) => case lookup nm top of
-                (Just (MkEntry name type (DCon k str))) =>
+                (Just (MkEntry _ name type (DCon k str))) =>
                   -- TODO check arity, also figure out why we need reverse
                   pure $ PatCon fc icit nm !(traverse (mkPat top) b)
                 -- This fires when a global is shadowed by a pattern var
@@ -994,21 +994,10 @@ check ctx tm ty = case (tm, !(forceType ctx.env ty)) of
     pure $ Lam (getFC tm) nm' Auto rig sc
 
   (tm,ty) => do
-    -- We need to insert if tm is not an Implicit Lam
-    -- assuming all of the implicit ty have been handled above
+    (tm', ty') <- infer ctx tm
+    (tm', ty') <- insert ctx tm' ty'
+
     let names = toList $ map fst ctx.types
-    (tm', ty') <- case !(infer ctx tm) of
-      -- Kovacs doesn't insert on tm = Implicit Lam, we don't have Plicity in Lam
-      -- so I'll check the inferred type for an implicit pi
-      -- This seems wrong, the ty' is what insert runs on, so we're just short circuiting here
-
-      -- REVIEW - I think we need icit on Lam, check that they match and drop the two "edge" above?
-      -- (tm'@(Lam{}), ty'@(VPi _ _ Implicit rig _ _)) => do debug "CheckMe 1"; pure (tm', ty')
-      -- (tm'@(Lam{}), ty'@(VPi _ _ Auto rig _ _)) => do debug "CheckMe 2"; pure (tm', ty')
-      (tm', ty') => do
-        debug "RUN INSERT ON \{pprint names tm'} at \{show ty'}"
-        insert ctx tm' ty'
-
     debug "INFER \{show tm} to (\{pprint names tm'} : \{show ty'}) expect \{show ty}"
     unifyCatch (getFC tm) ctx ty' ty
     pure tm'
@@ -1017,7 +1006,7 @@ infer ctx (RVar fc nm) = go 0 ctx.types
   where
     go : Nat -> Vect n (String, Val)  -> M  (Tm, Val)
     go i [] = case lookup nm !(get) of
-      Just (MkEntry name ty def) => do
+      Just (MkEntry _ name ty def) => do
         debug "lookup \{name} as \{show def}"
         pure (Ref fc nm def, !(eval [] CBN ty))
       Nothing => error fc "\{show nm} not in scope"

src/Lib/Erasure.idr

@@ -13,7 +13,7 @@ getType (Ref fc nm x) = do
   top <- get
   case lookup nm top of
     Nothing => pure Nothing
-    (Just (MkEntry name type def)) => pure $ Just type
+    (Just (MkEntry _ name type def)) => pure $ Just type
 getType tm = pure Nothing
 
 export
@@ -37,7 +37,7 @@ doAlt : EEnv -> CaseAlt -> M CaseAlt
 doAlt env (CaseDefault t) = CaseDefault <$> erase env t []
 doAlt env (CaseCons name args t) = do
   top <- get
-  let Just (MkEntry str type def) = lookup name top
+  let Just (MkEntry _ str type def) = lookup name top
     | _ => error emptyFC "\{name} dcon missing from context"
   let env' = piEnv env type args
   CaseCons name args <$> erase env' t []
@@ -58,8 +58,7 @@ erase env t sp = case t of
     top <- get
     case lookup nm top of
       Nothing => eraseSpine env t sp Nothing
-      (Just (MkEntry name type def)) => eraseSpine env t sp (Just type)
-  (Lam fc nm icit rig u) => Lam fc nm icit rig <$> erase ((nm, rig, Nothing) :: env) u []
+      (Just (MkEntry _ name type def)) => eraseSpine env t sp (Just type)
   (Lam fc nm icit rig u) => Lam fc nm icit rig <$> erase ((nm, rig, Nothing) :: env) u []
   -- If we get here, we're looking at a runtime pi type
   (Pi fc nm icit rig u v) => do

src/Lib/Eval.idr

@@ -73,7 +73,7 @@ export
 tryEval : Env -> Val -> M (Maybe Val)
 tryEval env (VRef fc k _ sp) =
   case lookup k !(get) of
-      Just (MkEntry name ty (Fn tm)) =>
+      Just (MkEntry _ name ty (Fn tm)) =>
         catchError {e=Error} (
             do
             debug "app \{name} to \{show sp}"
@@ -105,7 +105,7 @@ evalCase env mode sc@(VRef _ nm _ sp) (cc@(CaseCons name nms t) :: xs) =
       debug "ECase \{nm} \{show sp} \{show nms} \{showTm t}"
       go env (sp <>> []) nms
     else case lookup nm !(get) of
-      (Just (MkEntry str type (DCon k str1))) => evalCase env mode sc xs
+      (Just (MkEntry _ str type (DCon k str1))) => evalCase env mode sc xs
       -- bail for a stuck function
       _ => pure Nothing
   where

src/Lib/ProcessDecl.idr

@@ -29,7 +29,7 @@ isCandidate _ _ = False
 -- TODO consider ctx
 findMatches : Context -> Val -> List TopEntry -> M (List (Tm, MetaContext))
 findMatches ctx ty [] = pure []
-findMatches ctx ty ((MkEntry name type def) :: xs) = do
+findMatches ctx ty ((MkEntry _ name type def) :: xs) = do
   let True = isCandidate ty type | False => findMatches ctx ty xs
   top <- get
   -- let ctx = mkCtx (getFC ty)
@@ -181,8 +181,8 @@ processDecl (TypeSig fc names tm) = do
       | _ => error fc "\{show nm} is already defined"
     pure ()
   ty <- check (mkCtx fc) tm (VU fc)
+  ty <- zonk top 0 [] ty
   putStrLn "TypeSig \{unwords names} : \{pprint [] ty}"
-  debug "got \{pprint [] ty}"
   for_ names $ \nm => setDef nm fc ty Axiom
   -- Zoo4eg has metas in TypeSig, need to decide if I want to support leaving them unsolved here
   -- logMetas mstart
@@ -211,7 +211,7 @@ processDecl (Def fc nm clauses) = do
   let mstart = length mc.metas
   let Just entry = lookup nm top
     | Nothing => throwError $ E fc "No declaration for \{nm}"
-  let (MkEntry name ty Axiom) := entry
+  let (MkEntry fc name ty Axiom) := entry
     | _ => throwError $ E fc "\{nm} already defined"
 
   putStrLn "check \{nm} at \{pprint [] ty}"
@@ -324,11 +324,11 @@ processDecl (Instance instfc ty decls) = do
 
   let (Ref _ tconName _, args) := funArgs codomain
     | (tm, _) => error tyFC "\{pprint [] codomain} doesn't appear to be a TCon application"
-  let (Just (MkEntry name type (TCon cons))) = lookup tconName top
+  let (Just (MkEntry _ name type (TCon cons))) = lookup tconName top
     | _ => error tyFC "\{tconName} is not a type constructor"
   let [con] = cons
     | _ => error tyFC "\{tconName} has multiple constructors \{show cons}"
-  let (Just (MkEntry _ dcty (DCon _ _))) = lookup con top
+  let (Just (MkEntry _ _ dcty (DCon _ _))) = lookup con top
     | _ => error tyFC "can't find constructor \{show con}"
   vdcty@(VPi _ nm icit rig a b) <- eval [] CBN dcty
     | x => error (getFC x) "dcty not Pi"
@@ -402,9 +402,9 @@ processDecl (Data fc nm ty cons) = do
   let mstart = length mc.metas
   tyty <- check (mkCtx fc) ty (VU fc)
   case lookup nm top of
-    Just (MkEntry name type Axiom) => do
+    Just (MkEntry _ name type Axiom) => do
       unifyCatch fc (mkCtx fc) !(eval [] CBN tyty) !(eval [] CBN type)
-    Just (MkEntry name type _) => error fc "\{show nm} already declared"
+    Just (MkEntry _ name type _) => error fc "\{show nm} already declared"
     Nothing => setDef nm fc tyty Axiom
   cnames <- for cons $ \x => case x of
       (TypeSig fc names tm) => do

src/Lib/TopContext.idr

@@ -44,8 +44,8 @@ setDef name fc ty def = do
   put $ { defs := defs } top
   where
     go : List TopEntry -> M (List TopEntry)
-    go [] = pure $ [MkEntry name ty def]
-    go (x@(MkEntry nm ty' def') :: defs) = if nm == name
+    go [] = pure $ [MkEntry fc name ty def]
+    go (x@(MkEntry _ nm ty' def') :: defs) = if nm == name
       then error fc "\{name} is already defined"
       else (x ::) <$> go defs
 
@@ -58,8 +58,9 @@ updateDef name fc ty def = do
   where
     go : List TopEntry -> M (List TopEntry)
     go [] = error fc "\{name} not declared"
-    go (x@(MkEntry nm ty' def') :: defs) = if nm == name
-      then pure $ MkEntry name ty def :: defs
+    go (x@(MkEntry fc' nm ty' def') :: defs) = if nm == name
+      -- keep original fc, so it points to the TypeSig
+      then pure $ MkEntry fc' name ty def :: defs
       else (x ::) <$> go defs
 
 

src/Lib/Types.idr

@@ -404,6 +404,7 @@ Show Def where
 public export
 record TopEntry where
   constructor MkEntry
+  fc : FC
   name : String
   type : Tm
   def : Def
@@ -413,7 +414,7 @@ record TopEntry where
 export
 covering
 Show TopEntry where
-  show (MkEntry name type def) = "\{name} : \{show type} := \{show def}"
+  show (MkEntry fc name type def) = "\{name} : \{show type} := \{show def}"
 
 ||| Top level context.
 ||| Most of the reason this is separate is to have a different type

src/Main.idr

@@ -9,6 +9,7 @@ import Data.String
 import Data.Vect
 import Data.IORef
 -- import Lib.Elab
+import Lib.Common
 import Lib.Compile
 import Lib.Parser
 import Lib.Elab
@@ -29,6 +30,19 @@ import System.Path
 fail : String -> M a
 fail msg = putStrLn msg >> exitFailure
 
+jsonTopContext : M Json
+jsonTopContext = do
+  top <- get
+  pure $ JsonObj [("context", JsonArray (map jsonDef top.defs))]
+  where
+    jsonDef : TopEntry -> Json
+    -- There is no FC here...
+    jsonDef (MkEntry fc name type def) = JsonObj
+      [ ("fc", toJson fc)
+      , ("name", toJson name)
+      , ("type", toJson (render 80 $ pprint [] type) )
+      ]
+
 dumpContext : TopContext -> M ()
 dumpContext top = do
     putStrLn "Context:"
@@ -121,6 +135,7 @@ processFile fn = do
 
 cmdLine : List String -> M (Maybe String, List String)
 cmdLine [] = pure (Nothing, [])
+cmdLine ("--top" :: args) = cmdLine args -- handled later
 cmdLine ("-v" :: args) = do
   modify { verbose := True }
   cmdLine args
@@ -141,6 +156,8 @@ main' = do
   (out, files) <- cmdLine args
   traverse_ processFile files
 
+  when (elem "--top" args) $ putStrLn "TOP:\{renderJson !jsonTopContext}"
+
   case out of
     Nothing => pure ()
     Just name => writeSource name