diff --git a/TODO.md b/TODO.md index a97806c..e27f507 100644 --- a/TODO.md +++ b/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 => ...` -- [ ] Support @ on the LHS -- [ ] records + - [ ] `$` 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 diff --git a/newt-vscode/src/extension.ts b/newt-vscode/src/extension.ts index 4037f91..d06b55c 100644 --- a/newt-vscode/src/extension.ts +++ b/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,58 +31,83 @@ export function activate(context: vscode.ExtensionContext) { : path.dirname(fileName); const config = vscode.workspace.getConfiguration("newt"); const cmd = config.get("path", "build/exec/newt"); - const command = `${cmd} ${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}`); - } + 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}`); + } - // extract errors and messages from stdout - const lines = stdout.split("\n"); - const diagnostics: vscode.Diagnostic[] = []; + // extract errors and messages from stdout + const lines = stdout.split("\n"); + const diagnostics: vscode.Diagnostic[] = []; - 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); - 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 (match) { - let [_full, kind, file, line, column, message] = match; - // FIXME - check filename against current - console.log('********', file, fileName); - - let lnum = Number(line); - let cnum = Number(column); - 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); + 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); - // heuristics to grab the entire message: - // anything indented - // Context:, or Goal: are part of PRINTME - // unexpected / expecting appear in parse errors - while ( - lines[i + 1]?.match(/^( )/) - ) { - message += "\n" + lines[++i]; - } - 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); } + 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]; + 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); + + let lnum = Number(line); + let cnum = Number(column); + 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); + let range = + document.getWordRangeAtPosition(start) ?? + new vscode.Range(start, end); + // heuristics to grab the entire message: + // anything indented + // Context:, or Goal: are part of PRINTME + // unexpected / expecting appear in parse errors + while (lines[i + 1]?.match(/^( )/)) { + message += "\n" + lines[++i]; + } + 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); + } + } + } + diagnosticCollection.set(vscode.Uri.file(fileName), diagnostics); } - 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) => { diff --git a/playground/src/main.ts b/playground/src/main.ts index 7a768c9..075de4e 100644 --- a/playground/src/main.ts +++ b/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,15 +415,15 @@ const processOutput = ( kind === "ERROR" ? monaco.MarkerSeverity.Error : monaco.MarkerSeverity.Info; - if (kind === 'ERROR' || lineNumber) - markers.push({ - severity, - message, - startLineNumber: lineNumber, - endLineNumber: lineNumber, - startColumn: column, - endColumn, - }); + if (kind === "ERROR" || lineNumber) + markers.push({ + severity, + message, + startLineNumber: lineNumber, + endLineNumber: lineNumber, + startColumn: column, + endColumn, + }); } } monaco.editor.setModelMarkers(model, "newt", markers); diff --git a/playground/src/worker.ts b/playground/src/worker.ts index 42ef66a..2a12ea3 100644 --- a/playground/src/worker.ts +++ b/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'; diff --git a/src/Lib/Common.idr b/src/Lib/Common.idr index da9121c..13185c1 100644 --- a/src/Lib/Common.idr +++ b/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 diff --git a/src/Lib/Compile.idr b/src/Lib/Compile.idr index b37e5fa..edead2d 100644 --- a/src/Lib/Compile.idr +++ b/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.. diff --git a/src/Lib/CompileExp.idr b/src/Lib/CompileExp.idr index ce38ad9..a0eb0ec 100644 --- a/src/Lib/CompileExp.idr +++ b/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 diff --git a/src/Lib/Elab.idr b/src/Lib/Elab.idr index 973d531..b639ce7 100644 --- a/src/Lib/Elab.idr +++ b/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" diff --git a/src/Lib/Erasure.idr b/src/Lib/Erasure.idr index e9a4c01..1fec464 100644 --- a/src/Lib/Erasure.idr +++ b/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 diff --git a/src/Lib/Eval.idr b/src/Lib/Eval.idr index a7bf4ad..374e00f 100644 --- a/src/Lib/Eval.idr +++ b/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 diff --git a/src/Lib/ProcessDecl.idr b/src/Lib/ProcessDecl.idr index f8b70ab..27a3dd3 100644 --- a/src/Lib/ProcessDecl.idr +++ b/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 diff --git a/src/Lib/TopContext.idr b/src/Lib/TopContext.idr index 05187d9..639ad50 100644 --- a/src/Lib/TopContext.idr +++ b/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 diff --git a/src/Lib/Types.idr b/src/Lib/Types.idr index f05a258..62f0d4a 100644 --- a/src/Lib/Types.idr +++ b/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 diff --git a/src/Main.idr b/src/Main.idr index 92f0cd5..0e6853c 100644 --- a/src/Main.idr +++ b/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