Compare commits
10 Commits
697c5f2641
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
| 4814682712 | |||
| 2f1185bf4c | |||
| ee9664838f | |||
| ba519bdc7f | |||
| cb394d3cc2 | |||
| 3338a617cc | |||
| ac231173ed | |||
| f42f4aecbe | |||
| 766eb69313 | |||
| e2dfe4ec04 |
7
.gitignore
vendored
7
.gitignore
vendored
@@ -4,21 +4,18 @@ build/
|
|||||||
*.swp
|
*.swp
|
||||||
*.log
|
*.log
|
||||||
*.bak
|
*.bak
|
||||||
*.agda
|
|
||||||
*.agdai
|
|
||||||
/*.js
|
|
||||||
input.txt
|
input.txt
|
||||||
node_modules
|
node_modules
|
||||||
mkday.py
|
mkday.py
|
||||||
tmp
|
tmp
|
||||||
min.js.gz
|
min.js.gz
|
||||||
src/Revision.newt
|
src/Revision.newt
|
||||||
newt.ss
|
|
||||||
newt.so
|
|
||||||
.calva
|
.calva
|
||||||
.clj-kondo
|
.clj-kondo
|
||||||
.joyride
|
.joyride
|
||||||
.lsp
|
.lsp
|
||||||
.vscode
|
.vscode
|
||||||
|
.helix
|
||||||
bootstrap/serializer.js
|
bootstrap/serializer.js
|
||||||
/newt-vscode-lsp/src/newt.js
|
/newt-vscode-lsp/src/newt.js
|
||||||
|
/playground/src/newt.js
|
||||||
|
|||||||
88
Makefile
88
Makefile
@@ -1,51 +1,24 @@
|
|||||||
SRCS=$(shell find src -name "*.newt")
|
SRCS=$(shell find src -name "*.newt")
|
||||||
|
|
||||||
# Node shaves off 40% of the time.
|
|
||||||
# RUNJS=bun run
|
|
||||||
RUNJS=node
|
|
||||||
|
|
||||||
.PHONY:
|
.PHONY:
|
||||||
|
|
||||||
all: newt.js
|
all: build/newt.js
|
||||||
|
|
||||||
|
newt2: build/newt2.js
|
||||||
|
|
||||||
src/Revision.newt: .PHONY
|
newt3: build/newt3.js
|
||||||
sh ./scripts/mkrevision
|
|
||||||
|
|
||||||
newt.js: ${SRCS} src/Revision.newt
|
test: build/newt.js
|
||||||
$(RUNJS) bootstrap/newt.js src/Main.newt -o newt.js
|
|
||||||
|
|
||||||
newt2.js: newt.js
|
|
||||||
$(RUNJS) newt.js src/Main.newt -o newt2.js
|
|
||||||
|
|
||||||
newt3.js: newt2.js
|
|
||||||
time $(RUNJS) newt2.js src/Main.newt -o newt3.js
|
|
||||||
cmp newt2.js newt3.js
|
|
||||||
|
|
||||||
newt.ss: newt.js
|
|
||||||
$(RUNJS) newt.js src/Main.newt -o newt.ss
|
|
||||||
|
|
||||||
newt.so: newt.ss prim.ss
|
|
||||||
chez --script scripts/compile-chez.ss
|
|
||||||
|
|
||||||
newt2.ss: newt.so
|
|
||||||
chez --program newt.ss src/Main.newt -o newt2.ss
|
|
||||||
|
|
||||||
test: newt.js
|
|
||||||
scripts/test
|
scripts/test
|
||||||
|
|
||||||
cheztest: newt.so
|
cheztest: build/newt.so
|
||||||
make test NEWT='chez --program newt.so' RUNOUT="chez --script" OUTFILE=tmp/out.ss
|
make test NEWT='chez --program build/newt.so' RUNOUT="chez --script" OUTFILE=tmp/out.ss
|
||||||
|
|
||||||
aoctest: newt.js
|
aoctest: build/newt.js
|
||||||
scripts/aoc
|
scripts/aoc
|
||||||
scripts/aoc25
|
scripts/aoc25
|
||||||
|
|
||||||
# Misc
|
lsp: newt-vscode-lsp/dist/lsp.js playground/src/newt.js
|
||||||
|
|
||||||
# build / install old vscode extension
|
|
||||||
# vscode:
|
|
||||||
# cd newt-vscode && vsce package && code --install-extension *.vsix
|
|
||||||
|
|
||||||
# build / install new LSP vscode extension
|
# build / install new LSP vscode extension
|
||||||
vscode-lsp vscode: lsp
|
vscode-lsp vscode: lsp
|
||||||
@@ -55,29 +28,56 @@ playground: .PHONY
|
|||||||
cd playground && ./build
|
cd playground && ./build
|
||||||
|
|
||||||
profile: .PHONY
|
profile: .PHONY
|
||||||
rm isolate* build/*; node --prof newt.js -o newt2.js src/Main.newt
|
rm isolate* build/*
|
||||||
|
node --prof build/newt.js -o build/newt2.js src/Main.newt
|
||||||
node --prof-process isolate* > profile.txt
|
node --prof-process isolate* > profile.txt
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm newt*.js iife.js min.js min.js.gz
|
rm build/*
|
||||||
|
|
||||||
audit: .PHONY
|
audit: .PHONY
|
||||||
(cd playground && npm audit)
|
(cd playground && npm audit)
|
||||||
(cd newt-vscode && npm audit)
|
(cd newt-vscode && npm audit)
|
||||||
(cd newt-vscode-lsp && npm audit)
|
(cd newt-vscode-lsp && npm audit)
|
||||||
|
|
||||||
lsp.js: ${SRCS}
|
##
|
||||||
node newt.js src/LSP.newt -o lsp.js
|
|
||||||
|
|
||||||
newt-vscode-lsp/src/newt.js: lsp.js
|
build:
|
||||||
cp lsp.js $@
|
mkdir -p build
|
||||||
|
|
||||||
playground/src/newt.js: lsp.js
|
src/Revision.newt: .PHONY build
|
||||||
cp lsp.js $@
|
sh ./scripts/mkrevision
|
||||||
|
|
||||||
|
build/newt.js: ${SRCS} src/Revision.newt build
|
||||||
|
node bootstrap/newt.js src/Main.newt -o build/newt.js
|
||||||
|
|
||||||
|
build/newt2.js: build/newt.js
|
||||||
|
node build/newt.js src/Main.newt -o build/newt2.js
|
||||||
|
|
||||||
|
build/newt3.js: build/newt2.js
|
||||||
|
time node build/newt2.js src/Main.newt -o build/newt3.js
|
||||||
|
cmp build/newt2.js build/newt3.js
|
||||||
|
|
||||||
|
build/newt.ss: build/newt.js
|
||||||
|
node build/newt.js src/Main.newt -o build/newt.ss
|
||||||
|
|
||||||
|
build/newt.so: build/newt.ss prim.ss
|
||||||
|
chez --script scripts/compile-chez.ss
|
||||||
|
|
||||||
|
build/newt2.ss: build/newt.so
|
||||||
|
time chez --program build/newt.so src/Main.newt -o build/newt2.ss
|
||||||
|
|
||||||
|
build/lsp.js: ${SRCS} build/newt.js
|
||||||
|
node build/newt.js src/LSP.newt -o build/lsp.js
|
||||||
|
|
||||||
|
newt-vscode-lsp/src/newt.js: build/lsp.js
|
||||||
|
cp build/lsp.js $@
|
||||||
|
|
||||||
|
playground/src/newt.js: build/lsp.js
|
||||||
|
cp build/lsp.js $@
|
||||||
|
|
||||||
newt-vscode-lsp/dist/lsp.js: newt-vscode-lsp/src/lsp.ts newt-vscode-lsp/src/newt.js
|
newt-vscode-lsp/dist/lsp.js: newt-vscode-lsp/src/lsp.ts newt-vscode-lsp/src/newt.js
|
||||||
(cd newt-vscode-lsp && node esbuild.js)
|
(cd newt-vscode-lsp && node esbuild.js)
|
||||||
chmod +x $@
|
chmod +x $@
|
||||||
|
|
||||||
lsp: newt-vscode-lsp/dist/lsp.js playground/src/newt.js
|
|
||||||
|
|
||||||
|
|||||||
1197
bootstrap/newt.js
1197
bootstrap/newt.js
File diff suppressed because one or more lines are too long
@@ -1,8 +1,7 @@
|
|||||||
#!/bin/bash
|
#!/bin/bash
|
||||||
mkdir -p public
|
mkdir -p public
|
||||||
echo copy newt
|
echo build lsp.js
|
||||||
(cd .. && make lsp.js)
|
(cd .. && make lsp)
|
||||||
cp ../lsp.js src/newt.js
|
|
||||||
echo build newt worker
|
echo build newt worker
|
||||||
esbuild src/worker.ts --bundle --format=esm --platform=browser > public/worker.js
|
esbuild src/worker.ts --bundle --format=esm --platform=browser > public/worker.js
|
||||||
esbuild src/frame.ts --bundle --format=esm --platform=browser > public/frame.js
|
esbuild src/frame.ts --bundle --format=esm --platform=browser > public/frame.js
|
||||||
|
|||||||
@@ -7,6 +7,7 @@
|
|||||||
body {
|
body {
|
||||||
overflow: hidden;
|
overflow: hidden;
|
||||||
font-size: 12px;
|
font-size: 12px;
|
||||||
|
-webkit-text-size-adjust: none;
|
||||||
}
|
}
|
||||||
svg.icon path {
|
svg.icon path {
|
||||||
stroke: black;
|
stroke: black;
|
||||||
|
|||||||
@@ -2,7 +2,7 @@
|
|||||||
mkdir -p tmp
|
mkdir -p tmp
|
||||||
echo "Test AoC 2024 solutions"
|
echo "Test AoC 2024 solutions"
|
||||||
# FIXME - it turns out there are some stack issues here (including length)
|
# FIXME - it turns out there are some stack issues here (including length)
|
||||||
NCC="bun run newt.js"
|
NCC="bun run build/newt.js"
|
||||||
total=0
|
total=0
|
||||||
failed=0
|
failed=0
|
||||||
for fn in aoc2024/Day*.newt; do
|
for fn in aoc2024/Day*.newt; do
|
||||||
|
|||||||
@@ -1,7 +1,7 @@
|
|||||||
#!/bin/sh
|
#!/bin/sh
|
||||||
mkdir -p tmp
|
mkdir -p tmp
|
||||||
echo "Test AoC 2025 solutions"
|
echo "Test AoC 2025 solutions"
|
||||||
NCC="node newt.js"
|
NCC="node build/newt.js"
|
||||||
total=0
|
total=0
|
||||||
failed=0
|
failed=0
|
||||||
for fn in aoc2025/Day*.newt; do
|
for fn in aoc2025/Day*.newt; do
|
||||||
|
|||||||
@@ -1 +1 @@
|
|||||||
(parameterize ([optimize-level 3]) (compile-program "newt.ss"))
|
(parameterize ([optimize-level 3]) (compile-program "build/newt.ss"))
|
||||||
|
|||||||
@@ -1,7 +1,7 @@
|
|||||||
#!/bin/sh
|
#!/bin/sh
|
||||||
SAMPLES=$(find playground/samples -name "*.newt")
|
SAMPLES=$(find playground/samples -name "*.newt")
|
||||||
# NEWT ="bun run newt.js"
|
# NEWT ="bun run build/newt.js"
|
||||||
NEWT=${NEWT:="node newt.js"}
|
NEWT=${NEWT:="node build/newt.js"}
|
||||||
OUTFILE=${OUTFILE:="tmp/out.js"}
|
OUTFILE=${OUTFILE:="tmp/out.js"}
|
||||||
RUNOUT=${RUNOUT:="node"}
|
RUNOUT=${RUNOUT:="node"}
|
||||||
mkdir -p tmp
|
mkdir -p tmp
|
||||||
|
|||||||
@@ -38,7 +38,7 @@ switchModule repo modns = do
|
|||||||
top <- getTop
|
top <- getTop
|
||||||
-- mod <- processModule emptyFC repo Nil modns
|
-- mod <- processModule emptyFC repo Nil modns
|
||||||
let (Just mod) = lookupMap' modns top.modules | Nothing => pure Nothing
|
let (Just mod) = lookupMap' modns top.modules | Nothing => pure Nothing
|
||||||
modifyTop [ currentMod := mod; ops := mod.modOps ]
|
modifyTop { currentMod := mod; ops := mod.modOps }
|
||||||
pure $ Just mod
|
pure $ Just mod
|
||||||
|
|
||||||
data HoverInfo = NoHoverInfo | NeedCheck | HasHover FC String
|
data HoverInfo = NoHoverInfo | NeedCheck | HasHover FC String
|
||||||
|
|||||||
24
src/LSP.newt
24
src/LSP.newt
@@ -68,12 +68,12 @@ lspFileSource = do
|
|||||||
|
|
||||||
updateFile : String → String → Unit
|
updateFile : String → String → Unit
|
||||||
updateFile fn src = unsafePerformIO $ do
|
updateFile fn src = unsafePerformIO $ do
|
||||||
modifyIORef state [ files $= updateMap fn src ]
|
modifyIORef state { files $= updateMap fn src }
|
||||||
st <- readIORef state
|
st <- readIORef state
|
||||||
let (base,modName) = decomposeName fn
|
let (base,modName) = decomposeName fn
|
||||||
Right (ctx,_) <- (invalidateModule modName).runM st.topContext
|
Right (ctx,_) <- (invalidateModule modName).runM st.topContext
|
||||||
| _ => writeIORef state st
|
| _ => writeIORef state st
|
||||||
modifyIORef state [ topContext := ctx ]
|
modifyIORef state { topContext := ctx }
|
||||||
|
|
||||||
|
|
||||||
fcToRange : FC → Json
|
fcToRange : FC → Json
|
||||||
@@ -96,17 +96,17 @@ hoverInfo uri line col = unsafePerformIO $ do
|
|||||||
-- We're proactively running check if there is no module information, make sure we save it
|
-- We're proactively running check if there is no module information, make sure we save it
|
||||||
Right (top, HasHover fc msg) <- (getHoverInfo repo modns line col).runM st.topContext
|
Right (top, HasHover fc msg) <- (getHoverInfo repo modns line col).runM st.topContext
|
||||||
| Right (top, NeedCheck) => do
|
| Right (top, NeedCheck) => do
|
||||||
modifyIORef state $ [ topContext := top ]
|
modifyIORef state $ { topContext := top }
|
||||||
putStrLn $ "NeedsCheck"
|
putStrLn $ "NeedsCheck"
|
||||||
pure $ js_castBool True
|
pure $ js_castBool True
|
||||||
| Right (top, NoHoverInfo) => do
|
| Right (top, NoHoverInfo) => do
|
||||||
modifyIORef state $ [ topContext := top ]
|
modifyIORef state $ { topContext := top }
|
||||||
putStrLn $ "Nothing to see here"
|
putStrLn $ "Nothing to see here"
|
||||||
pure $ js_castBool True
|
pure $ js_castBool True
|
||||||
| Left err => do
|
| Left err => do
|
||||||
putStrLn $ showError "" err
|
putStrLn $ showError "" err
|
||||||
pure $ jsonToJObject JsonNull
|
pure $ jsonToJObject JsonNull
|
||||||
modifyIORef state $ [ topContext := top ]
|
modifyIORef state $ { topContext := top }
|
||||||
let location = JsonObj $ ("uri", JsonStr fc.file) :: ("range", fcToRange fc) :: Nil
|
let location = JsonObj $ ("uri", JsonStr fc.file) :: ("range", fcToRange fc) :: Nil
|
||||||
pure $ jsonToJObject $ JsonObj $ ("info", JsonStr msg) :: ("location", location) :: Nil
|
pure $ jsonToJObject $ JsonObj $ ("info", JsonStr msg) :: ("location", location) :: Nil
|
||||||
|
|
||||||
@@ -126,7 +126,7 @@ codeActionInfo uri line col = unsafePerformIO $ do
|
|||||||
putStrLn "ACTIONS ERROR"
|
putStrLn "ACTIONS ERROR"
|
||||||
putStrLn $ showError "" err
|
putStrLn $ showError "" err
|
||||||
pure js_null
|
pure js_null
|
||||||
modifyIORef state $ [ topContext := top ]
|
modifyIORef state $ { topContext := top }
|
||||||
pure $ jsonToJObject $ JsonArray $ map actionToJson actions
|
pure $ jsonToJObject $ JsonArray $ map actionToJson actions
|
||||||
where
|
where
|
||||||
single : String → Json → Json
|
single : String → Json → Json
|
||||||
@@ -238,7 +238,7 @@ checkFile fn = unsafePerformIO $ do
|
|||||||
(Right (top, json)) <- (do
|
(Right (top, json)) <- (do
|
||||||
putStrLn "processModule"
|
putStrLn "processModule"
|
||||||
mod <- processModule emptyFC repo Nil modName
|
mod <- processModule emptyFC repo Nil modName
|
||||||
modifyTop [ currentMod := mod; ops := mod.modOps ]
|
modifyTop { currentMod := mod; ops := mod.modOps }
|
||||||
|
|
||||||
-- pull out errors and infos
|
-- pull out errors and infos
|
||||||
top <- getTop
|
top <- getTop
|
||||||
@@ -251,7 +251,7 @@ checkFile fn = unsafePerformIO $ do
|
|||||||
putStrLn $ showError "" err
|
putStrLn $ showError "" err
|
||||||
pure $ jsonToJObject $ JsonArray $ errorToDiag err :: Nil
|
pure $ jsonToJObject $ JsonArray $ errorToDiag err :: Nil
|
||||||
-- Cache loaded modules
|
-- Cache loaded modules
|
||||||
modifyIORef state $ [ topContext := top ]
|
modifyIORef state $ { topContext := top }
|
||||||
pure $ jsonToJObject $ JsonArray json
|
pure $ jsonToJObject $ JsonArray json
|
||||||
|
|
||||||
docSymbols : String → JSObject
|
docSymbols : String → JSObject
|
||||||
@@ -265,11 +265,11 @@ docSymbols fn = unsafePerformIO $ do
|
|||||||
repo <- lspFileSource
|
repo <- lspFileSource
|
||||||
(Right (top, json)) <- (do
|
(Right (top, json)) <- (do
|
||||||
mod <- processModule emptyFC repo Nil modName
|
mod <- processModule emptyFC repo Nil modName
|
||||||
modifyTop [ currentMod := mod; ops := mod.modOps ]
|
modifyTop { currentMod := mod; ops := mod.modOps }
|
||||||
getSymbols).runM st.topContext
|
getSymbols).runM st.topContext
|
||||||
| Left err => do
|
| Left err => do
|
||||||
pure $ jsonToJObject $ JsonNull
|
pure $ jsonToJObject $ JsonNull
|
||||||
modifyIORef state $ [ topContext := top ]
|
modifyIORef state $ { topContext := top }
|
||||||
pure $ jsonToJObject $ JsonArray json
|
pure $ jsonToJObject $ JsonArray json
|
||||||
|
|
||||||
compileJS : String → JSObject
|
compileJS : String → JSObject
|
||||||
@@ -287,7 +287,7 @@ compileJS fn = unsafePerformIO $ do
|
|||||||
++ map (render 90 ∘ noAlt) docs
|
++ map (render 90 ∘ noAlt) docs
|
||||||
pure src).runM st.topContext
|
pure src).runM st.topContext
|
||||||
| Left err => pure $ js_castStr "// \{errorMsg err}"
|
| Left err => pure $ js_castStr "// \{errorMsg err}"
|
||||||
modifyIORef state [ topContext := top ]
|
modifyIORef state { topContext := top }
|
||||||
pure $ js_castStr src
|
pure $ js_castStr src
|
||||||
|
|
||||||
compileToScheme : String → JSObject
|
compileToScheme : String → JSObject
|
||||||
@@ -302,7 +302,7 @@ compileToScheme fn = unsafePerformIO $ do
|
|||||||
let src = unlines docs
|
let src = unlines docs
|
||||||
pure src).runM st.topContext
|
pure src).runM st.topContext
|
||||||
| Left err => pure $ js_castStr ";; \{errorMsg err}"
|
| Left err => pure $ js_castStr ";; \{errorMsg err}"
|
||||||
modifyIORef state [ topContext := top ]
|
modifyIORef state { topContext := top }
|
||||||
pure $ js_castStr src
|
pure $ js_castStr src
|
||||||
|
|
||||||
#export updateFile checkFile hoverInfo codeActionInfo compileJS docSymbols compileToScheme
|
#export updateFile checkFile hoverInfo codeActionInfo compileJS docSymbols compileToScheme
|
||||||
|
|||||||
@@ -119,14 +119,12 @@ cexpToScm env (CCase sc alts) = do
|
|||||||
withVar env sc $ \ nm => doCase nm alts
|
withVar env sc $ \ nm => doCase nm alts
|
||||||
where
|
where
|
||||||
-- add a bunch of lets then do body
|
-- add a bunch of lets then do body
|
||||||
conAlt : SCEnv → String → SnocList String → List String → List Quant → CExp → String
|
conAlt : SCEnv → String → Int → List String → List Quant → CExp → String
|
||||||
conAlt env nm lets Nil Nil body = "(let (\{joinBy " " (lets <>> Nil)}) \{cexpToScm env body})"
|
conAlt env nm ix Nil Nil body = cexpToScm env body
|
||||||
-- TODO let `vector-ref nm ..`` vs `#f` (erased) in env for erased fields
|
conAlt env nm ix (arg :: args) (Many :: qs) body =
|
||||||
conAlt env nm lets (arg :: args) (Many :: qs) body = case scbind arg env of
|
conAlt ("(vector-ref \{nm} \{show ix})" :: env) nm (ix + 1) args qs body
|
||||||
(arg', env') => let ix = 1 + snoclen' lets
|
conAlt env nm ix (arg :: args) (Zero :: qs) body = conAlt ("#f" :: env) nm ix args qs body
|
||||||
in conAlt env' nm (lets :< "(\{arg'} (vector-ref \{nm} \{show ix}))") args qs body
|
conAlt env nm ix _ _ body = fatalError "arg/qs mismatch in conAlt"
|
||||||
conAlt env nm lets (arg :: args) (Zero :: qs) body = conAlt ("#f" :: env) nm lets args qs body
|
|
||||||
conAlt env nm lets _ _ body = fatalError "arg/qs mismatch in conAlt"
|
|
||||||
|
|
||||||
nilAlt : SCEnv → List Quant → CExp → String
|
nilAlt : SCEnv → List Quant → CExp → String
|
||||||
nilAlt env Nil body = cexpToScm env body
|
nilAlt env Nil body = cexpToScm env body
|
||||||
@@ -145,7 +143,7 @@ cexpToScm env (CCase sc alts) = do
|
|||||||
-- an alt branch in a `case` statement
|
-- an alt branch in a `case` statement
|
||||||
-- for the Nil/Cons case, we're not inside a `case`.
|
-- for the Nil/Cons case, we're not inside a `case`.
|
||||||
doAlt : String → CAlt → String
|
doAlt : String → CAlt → String
|
||||||
doAlt nm (CConAlt tag cname _ args qs body) = "((\{show tag}) \{conAlt env nm Lin args qs body})"
|
doAlt nm (CConAlt tag cname _ args qs body) = "((\{show tag}) \{conAlt env nm 1 args qs body})"
|
||||||
doAlt nm (CDefAlt body) = "(else \{cexpToScm env body})"
|
doAlt nm (CDefAlt body) = "(else \{cexpToScm env body})"
|
||||||
doAlt nm (CLitAlt lit body) = "((\{scmLit lit}) \{cexpToScm env body})"
|
doAlt nm (CLitAlt lit body) = "((\{scmLit lit}) \{cexpToScm env body})"
|
||||||
|
|
||||||
@@ -170,7 +168,7 @@ cexpToScm env (CCase sc alts) = do
|
|||||||
(CConAlt _ _ info _ _ _ :: _) => fatalError "\{show info} alt after nil"
|
(CConAlt _ _ info _ _ _ :: _) => fatalError "\{show info} alt after nil"
|
||||||
(CLitAlt _ _ :: _) => fatalError "lit alt after nil"
|
(CLitAlt _ _ :: _) => fatalError "lit alt after nil"
|
||||||
_ => fatalError "too many alts after cons"
|
_ => fatalError "too many alts after cons"
|
||||||
doCase nm (CConAlt tag cname _ args qs body :: Nil) = conAlt env nm Lin args qs body
|
doCase nm (CConAlt tag cname _ args qs body :: Nil) = conAlt env nm 1 args qs body
|
||||||
doCase nm (CLitAlt _ body :: Nil) = cexpToScm env body
|
doCase nm (CLitAlt _ body :: Nil) = cexpToScm env body
|
||||||
doCase nm (CDefAlt body :: Nil) = cexpToScm env body
|
doCase nm (CDefAlt body :: Nil) = cexpToScm env body
|
||||||
doCase nm alts@(CLitAlt _ _ :: _) = "(case \{nm} \{joinBy " " $ map (doAlt nm) alts})"
|
doCase nm alts@(CLitAlt _ _ :: _) = "(case \{nm} \{joinBy " " $ map (doAlt nm) alts})"
|
||||||
|
|||||||
@@ -80,6 +80,18 @@ lookupDef ctx name = go 0 ctx.types ctx.env
|
|||||||
go ix ((nm, ty) :: xs) (v :: vs) = if nm == name then Just v else go (1 + ix) xs vs
|
go ix ((nm, ty) :: xs) (v :: vs) = if nm == name then Just v else go (1 + ix) xs vs
|
||||||
go ix _ _ = Nothing
|
go ix _ _ = Nothing
|
||||||
|
|
||||||
|
expandList : FC → Maybe Raw → Raw
|
||||||
|
expandList fc Nothing = RVar fc "Nil"
|
||||||
|
expandList fc (Just t) = go fc t
|
||||||
|
where
|
||||||
|
cons : FC → Raw → Raw → Raw
|
||||||
|
cons fc t u = RApp fc (RApp fc (RVar fc "_::_") t Explicit) u Explicit
|
||||||
|
|
||||||
|
go : FC → Raw → Raw
|
||||||
|
go fc (RApp fc' (RApp fc'' (RVar fc "_,_") t Explicit) u Explicit) =
|
||||||
|
cons fc t $ go fc u
|
||||||
|
go fc t = cons fc t (RVar fc "Nil")
|
||||||
|
|
||||||
forceMeta : Val -> M Val
|
forceMeta : Val -> M Val
|
||||||
forceMeta (VMeta fc ix sp) = do
|
forceMeta (VMeta fc ix sp) = do
|
||||||
meta <- lookupMeta ix
|
meta <- lookupMeta ix
|
||||||
@@ -118,10 +130,10 @@ isCandidate _ _ = False
|
|||||||
|
|
||||||
setMetaMode : MetaMode → M Unit
|
setMetaMode : MetaMode → M Unit
|
||||||
-- ideally we would support dotted paths like metaCtx.mcmode := CheckFirst
|
-- ideally we would support dotted paths like metaCtx.mcmode := CheckFirst
|
||||||
setMetaMode mcmode = modifyTop [ currentMod $= [modMetaCtx $= [mcmode := mcmode] ] ]
|
setMetaMode mcmode = modifyTop { currentMod $= {modMetaCtx $= {mcmode := mcmode} } }
|
||||||
|
|
||||||
setMetaContext : MetaContext → M Unit
|
setMetaContext : MetaContext → M Unit
|
||||||
setMetaContext mc = modifyTop [ currentMod $= [ modMetaCtx := mc ]]
|
setMetaContext mc = modifyTop { currentMod $= { modMetaCtx := mc }}
|
||||||
|
|
||||||
findMatches : Context -> Val -> List (QName × Tm) -> M (List QName)
|
findMatches : Context -> Val -> List (QName × Tm) -> M (List QName)
|
||||||
findMatches ctx ty Nil = pure Nil
|
findMatches ctx ty Nil = pure Nil
|
||||||
@@ -138,7 +150,6 @@ findMatches ctx ty ((name, type) :: xs) = do
|
|||||||
debug $ \ _ => "TRY \{show name} : \{rpprint Nil type} for \{show ty}"
|
debug $ \ _ => "TRY \{show name} : \{rpprint Nil type} for \{show ty}"
|
||||||
-- This check is solving metas, so we save mc below in case we want this solution
|
-- This check is solving metas, so we save mc below in case we want this solution
|
||||||
let (QN ns nm) = name
|
let (QN ns nm) = name
|
||||||
let (cod, tele) = splitTele type
|
|
||||||
setMetaMode CheckFirst
|
setMetaMode CheckFirst
|
||||||
tm <- check ctx (RVar fc nm) ty
|
tm <- check ctx (RVar fc nm) ty
|
||||||
debug $ \ _ => "Found \{rpprint Nil tm} for \{show ty}"
|
debug $ \ _ => "Found \{rpprint Nil tm} for \{show ty}"
|
||||||
@@ -256,7 +267,7 @@ updateMeta ix f = do
|
|||||||
let autos = case me of
|
let autos = case me of
|
||||||
Solved _ _ _ => filter (_/=_ ix) mc.autos
|
Solved _ _ _ => filter (_/=_ ix) mc.autos
|
||||||
_ => mc.autos
|
_ => mc.autos
|
||||||
setMetaContext $ [metas $= updateMap ix me; autos := autos] mc
|
setMetaContext $ {metas $= updateMap ix me; autos := autos} mc
|
||||||
|
|
||||||
-- Try to solve autos that reference the meta ix
|
-- Try to solve autos that reference the meta ix
|
||||||
checkAutos : QName -> List QName -> M Unit
|
checkAutos : QName -> List QName -> M Unit
|
||||||
@@ -344,19 +355,10 @@ rename meta ren lvl (VPi fc n icit rig ty tm) = do
|
|||||||
pure (Pi fc n icit rig ty' scope')
|
pure (Pi fc n icit rig ty' scope')
|
||||||
rename meta ren lvl (VU fc) = pure (UU fc)
|
rename meta ren lvl (VU fc) = pure (UU fc)
|
||||||
rename meta ren lvl (VErased fc) = pure (Erased fc)
|
rename meta ren lvl (VErased fc) = pure (Erased fc)
|
||||||
-- for now, we don't do solutions with case in them.
|
|
||||||
rename meta ren lvl (VCase fc sc alts) = error fc "Case in solution"
|
|
||||||
rename meta ren lvl (VLit fc lit) = pure (Lit fc lit)
|
rename meta ren lvl (VLit fc lit) = pure (Lit fc lit)
|
||||||
rename meta ren lvl (VLet fc name val body) = do
|
-- for now, we don't do solutions with case, let, letrec in them
|
||||||
val' <- rename meta ren lvl val
|
-- If we we need this, follow the model of VLam
|
||||||
body' <- rename meta (lvl :: ren) (1 + lvl) body
|
rename meta ren lvl tm = error (getFC tm) "Unhandled term in `rename`: \{show tm}"
|
||||||
pure $ Let fc name val' body'
|
|
||||||
-- these probably shouldn't show up in solutions...
|
|
||||||
rename meta ren lvl (VLetRec fc name ty val body) = do
|
|
||||||
ty' <- rename meta ren lvl ty
|
|
||||||
val' <- rename meta (lvl :: ren) (1 + lvl) val
|
|
||||||
body' <- rename meta (lvl :: ren) (1 + lvl) body
|
|
||||||
pure $ LetRec fc name ty' val' body'
|
|
||||||
|
|
||||||
lams : Nat -> List String -> Tm -> Tm
|
lams : Nat -> List String -> Tm -> Tm
|
||||||
lams Z _ tm = tm
|
lams Z _ tm = tm
|
||||||
@@ -628,7 +630,7 @@ freshMeta ctx fc ty kind = do
|
|||||||
let autos = case kind of
|
let autos = case kind of
|
||||||
AutoSolve => qn :: mc.autos
|
AutoSolve => qn :: mc.autos
|
||||||
_ => mc.autos
|
_ => mc.autos
|
||||||
setMetaContext $ [ metas $= updateMap qn newmeta; autos := autos; next $= 1 +] mc
|
setMetaContext $ { metas $= updateMap qn newmeta; autos := autos; next $= 1 +} mc
|
||||||
|
|
||||||
-- I tried checking Auto immediately if CheckAll, but there isn't enough information yet.
|
-- I tried checking Auto immediately if CheckAll, but there isn't enough information yet.
|
||||||
pure $ applyBDs 0 (Meta fc qn) ctx.bds
|
pure $ applyBDs 0 (Meta fc qn) ctx.bds
|
||||||
@@ -749,7 +751,6 @@ substVal k v tm = go tm
|
|||||||
where
|
where
|
||||||
go : Val -> Val
|
go : Val -> Val
|
||||||
go (VVar fc j sp) = if j == k then v else (VVar fc j (map go sp))
|
go (VVar fc j sp) = if j == k then v else (VVar fc j (map go sp))
|
||||||
go (VLet fc nm a b) = VLet fc nm (go a) b
|
|
||||||
go (VPi fc nm icit rig a b) = VPi fc nm icit rig (go a) b
|
go (VPi fc nm icit rig a b) = VPi fc nm icit rig (go a) b
|
||||||
go (VMeta fc ix sp) = VMeta fc ix (map go sp)
|
go (VMeta fc ix sp) = VMeta fc ix (map go sp)
|
||||||
go (VRef fc nm sp) = VRef fc nm (map go sp)
|
go (VRef fc nm sp) = VRef fc nm (map go sp)
|
||||||
@@ -988,6 +989,7 @@ mkPat (RAs fc as tm, icit) = do
|
|||||||
(PatCon fc icit nm args Nothing) => pure $ PatCon fc icit nm args (Just as)
|
(PatCon fc icit nm args Nothing) => pure $ PatCon fc icit nm args (Just as)
|
||||||
(PatCon fc icit nm args _) => error fc "Double as pattern \{show tm}"
|
(PatCon fc icit nm args _) => error fc "Double as pattern \{show tm}"
|
||||||
t => error fc "Can't put as on non-constructor \{show tm}"
|
t => error fc "Can't put as on non-constructor \{show tm}"
|
||||||
|
mkPat (RList fc mt, icit) = mkPat (expandList fc mt, icit)
|
||||||
mkPat (tm, icit) = do
|
mkPat (tm, icit) = do
|
||||||
top <- getTop
|
top <- getTop
|
||||||
case splitArgs tm Nil of
|
case splitArgs tm Nil of
|
||||||
@@ -1549,6 +1551,8 @@ infer ctx (RVar fc nm) = go 0 ctx.types
|
|||||||
go i ((x, ty) :: xs) = if x == nm then pure (Bnd fc i, ty)
|
go i ((x, ty) :: xs) = if x == nm then pure (Bnd fc i, ty)
|
||||||
else go (i + 1) xs
|
else go (i + 1) xs
|
||||||
|
|
||||||
|
infer ctx (RList fc mt) = infer ctx $ expandList fc mt
|
||||||
|
|
||||||
infer ctx (RApp fc t u icit) = do
|
infer ctx (RApp fc t u icit) = do
|
||||||
-- If the app is explicit, add any necessary metas
|
-- If the app is explicit, add any necessary metas
|
||||||
(icit, t, tty) <- case icit of
|
(icit, t, tty) <- case icit of
|
||||||
|
|||||||
@@ -9,6 +9,7 @@ import Lib.TopContext
|
|||||||
import Data.IORef
|
import Data.IORef
|
||||||
import Data.SnocList
|
import Data.SnocList
|
||||||
import Data.SortedMap
|
import Data.SortedMap
|
||||||
|
import Lib.Error
|
||||||
|
|
||||||
eval : Env -> Tm -> M Val
|
eval : Env -> Tm -> M Val
|
||||||
|
|
||||||
@@ -27,6 +28,7 @@ vapp (VLam _ _ _ _ t) u = t $$ u
|
|||||||
vapp (VVar fc k sp) u = pure $ VVar fc k (sp :< u)
|
vapp (VVar fc k sp) u = pure $ VVar fc k (sp :< u)
|
||||||
vapp (VRef fc nm sp) u = pure $ VRef fc nm (sp :< u)
|
vapp (VRef fc nm sp) u = pure $ VRef fc nm (sp :< u)
|
||||||
vapp (VMeta fc k sp) u = pure $ VMeta fc k (sp :< u)
|
vapp (VMeta fc k sp) u = pure $ VMeta fc k (sp :< u)
|
||||||
|
-- not really impossible, could be a stuck VCase.
|
||||||
vapp t u = error' "impossible in vapp \{show t} to \{show u}\n"
|
vapp t u = error' "impossible in vapp \{show t} to \{show u}\n"
|
||||||
|
|
||||||
vappSpine : Val -> SnocList Val -> M Val
|
vappSpine : Val -> SnocList Val -> M Val
|
||||||
@@ -69,8 +71,9 @@ tryEval env (VRef fc k sp) = do
|
|||||||
vtm <- eval env tm
|
vtm <- eval env tm
|
||||||
debug $ \ _ => "tm is \{render 90 $ pprint Nil tm}"
|
debug $ \ _ => "tm is \{render 90 $ pprint Nil tm}"
|
||||||
val <- vappSpine vtm sp
|
val <- vappSpine vtm sp
|
||||||
|
-- These are considered "stuck" and we back out to the nearest name application
|
||||||
case val of
|
case val of
|
||||||
VCase _ _ _ => pure Nothing
|
VCase _ _ _ _ => pure Nothing
|
||||||
VLam _ _ _ _ _ => pure Nothing
|
VLam _ _ _ _ _ => pure Nothing
|
||||||
-- For now? There is a spot in Compile.newt that has
|
-- For now? There is a spot in Compile.newt that has
|
||||||
-- two applications of fresh that is getting unfolded even
|
-- two applications of fresh that is getting unfolded even
|
||||||
@@ -78,7 +81,7 @@ tryEval env (VRef fc k sp) = do
|
|||||||
-- coming out of a let and is instantly applied
|
-- coming out of a let and is instantly applied
|
||||||
VLetRec _ _ _ _ _ => pure Nothing
|
VLetRec _ _ _ _ _ => pure Nothing
|
||||||
v => pure $ Just v)
|
v => pure $ Just v)
|
||||||
(\ _ => pure Nothing)
|
(const $ pure Nothing)
|
||||||
_ => do
|
_ => do
|
||||||
debug $ \ _ => "tryEval blocked on undefined \{show k}"
|
debug $ \ _ => "tryEval blocked on undefined \{show k}"
|
||||||
pure Nothing
|
pure Nothing
|
||||||
@@ -98,7 +101,7 @@ forceType env x = do
|
|||||||
| _ => pure x
|
| _ => pure x
|
||||||
forceType env x'
|
forceType env x'
|
||||||
|
|
||||||
-- for cases applied to a value
|
-- Handles cases applied to a value, return Nothing if stuck
|
||||||
-- TODO this does not handle CaseLit
|
-- TODO this does not handle CaseLit
|
||||||
evalCase : Env -> Val -> List CaseAlt -> M (Maybe Val)
|
evalCase : Env -> Val -> List CaseAlt -> M (Maybe Val)
|
||||||
evalCase env sc@(VRef _ nm sp) (cc@(CaseCons name nms t) :: xs) = do
|
evalCase env sc@(VRef _ nm sp) (cc@(CaseCons name nms t) :: xs) = do
|
||||||
@@ -112,40 +115,19 @@ evalCase env sc@(VRef _ nm sp) (cc@(CaseCons name nms t) :: xs) = do
|
|||||||
-- bail for a stuck function
|
-- bail for a stuck function
|
||||||
_ => pure Nothing
|
_ => pure Nothing
|
||||||
where
|
where
|
||||||
|
-- put constructor args into scope
|
||||||
pushArgs : Env -> List Val -> List String -> M (Maybe Val)
|
pushArgs : Env -> List Val -> List String -> M (Maybe Val)
|
||||||
pushArgs env (arg :: args) (nm :: nms) = pushArgs (arg :: env) args nms
|
pushArgs env (arg :: args) (nm :: nms) = pushArgs (arg :: env) args nms
|
||||||
pushArgs env args Nil = do
|
pushArgs env Nil Nil = Just <$> eval env t
|
||||||
t' <- eval env t
|
pushArgs env args Nil = fatalError "Extra args \{show args}"
|
||||||
Just <$> vappSpine t' (Lin <>< args)
|
|
||||||
pushArgs env Nil rest = pure Nothing
|
pushArgs env Nil rest = pure Nothing
|
||||||
-- REVIEW - this is handled in the caller already
|
|
||||||
evalCase env sc@(VVar fc k sp) alts = case lookupVar env k of
|
|
||||||
Just tt@(VVar fc' k' sp') => do
|
|
||||||
debug $ \ _ => "lookup \{show k} is \{show tt}"
|
|
||||||
if k' == k
|
|
||||||
then pure Nothing
|
|
||||||
else do
|
|
||||||
val <- vappSpine (VVar fc' k' sp') sp
|
|
||||||
evalCase env val alts
|
|
||||||
Just t => do
|
|
||||||
val <- vappSpine t sp
|
|
||||||
evalCase env val alts
|
|
||||||
Nothing => do
|
|
||||||
debug $ \ _ => "lookup \{show k} is Nothing in env \{show env}"
|
|
||||||
pure Nothing
|
|
||||||
evalCase env sc (CaseDefault u :: xs) = Just <$> eval env u
|
evalCase env sc (CaseDefault u :: xs) = Just <$> eval env u
|
||||||
evalCase env sc cc = do
|
evalCase env sc cc = do
|
||||||
debug $ \ _ => "CASE BAIL sc \{show sc} vs " -- \{show cc}"
|
debug $ \ _ => "CASE BAIL sc \{show sc} vs " -- \{show cc}"
|
||||||
debug $ \ _ => "env is \{show env}"
|
debug $ \ _ => "env is \{show env}"
|
||||||
pure Nothing
|
pure Nothing
|
||||||
|
|
||||||
-- neutral alts
|
|
||||||
evalAlt : Env → CaseAlt → M VCaseAlt
|
|
||||||
evalAlt env (CaseDefault tm) = VCaseDefault <$> eval env tm
|
|
||||||
evalAlt env (CaseLit lit tm) = VCaseLit lit <$> eval env tm
|
|
||||||
-- in the cons case, we're binding args
|
|
||||||
evalAlt env (CaseCons nm args tm) = pure $ VCaseCons nm args env tm
|
|
||||||
|
|
||||||
-- So smalltt says:
|
-- So smalltt says:
|
||||||
-- Smalltt has the following approach:
|
-- Smalltt has the following approach:
|
||||||
-- - Top-level and local definitions are lazy.
|
-- - Top-level and local definitions are lazy.
|
||||||
@@ -173,13 +155,19 @@ eval env (Pi fc x icit rig a b) = do
|
|||||||
pure $ VPi fc x icit rig a' (MkClosure env b)
|
pure $ VPi fc x icit rig a' (MkClosure env b)
|
||||||
eval env (Let fc nm t u) = do
|
eval env (Let fc nm t u) = do
|
||||||
t' <- eval env t
|
t' <- eval env t
|
||||||
u' <- eval (VVar fc (length' env) Lin :: env) u
|
--
|
||||||
pure $ VLet fc nm t' u'
|
if True
|
||||||
|
then pure $ VLet fc nm t' (MkClosure env u)
|
||||||
|
else eval (t' :: env) u
|
||||||
eval env (LetRec fc nm ty t u) = do
|
eval env (LetRec fc nm ty t u) = do
|
||||||
ty' <- eval env ty
|
-- Used for `where`, we'd probably need to treat this like Lam.
|
||||||
t' <- eval (VVar fc (length' env) Lin :: env) t
|
error fc "eval letrec"
|
||||||
u' <- eval (VVar fc (length' env) Lin :: env) u
|
-- I think we need to handle this like lam/let, disabled for now.
|
||||||
pure $ VLetRec fc nm ty' t' u'
|
-- It should be gone by the time we hit inlining, we'll see if it arises in other cases
|
||||||
|
-- ty' <- eval env ty
|
||||||
|
-- t' <- eval (VVar fc (length' env) Lin :: env) t
|
||||||
|
-- u' <- eval (VVar fc (length' env) Lin :: env) u
|
||||||
|
-- pure $ VLetRec fc nm ty' t' u'
|
||||||
-- Here, we assume env has everything. We push levels onto it during type checking.
|
-- Here, we assume env has everything. We push levels onto it during type checking.
|
||||||
-- I think we could pass in an l and assume everything outside env is free and
|
-- I think we could pass in an l and assume everything outside env is free and
|
||||||
-- translate to a level
|
-- translate to a level
|
||||||
@@ -191,15 +179,13 @@ eval env (Lit fc lit) = pure $ VLit fc lit
|
|||||||
eval env tm@(Case fc sc alts) = do
|
eval env tm@(Case fc sc alts) = do
|
||||||
-- TODO we need to be able to tell eval to expand aggressively here.
|
-- TODO we need to be able to tell eval to expand aggressively here.
|
||||||
sc' <- eval env sc
|
sc' <- eval env sc
|
||||||
sc' <- unlet env sc' -- try to expand lets from pattern matching
|
-- inline metas and do beta reduction at head
|
||||||
-- possibly too aggressive?
|
|
||||||
sc' <- forceType env sc'
|
sc' <- forceType env sc'
|
||||||
Nothing <- evalCase env sc' alts
|
Nothing <- evalCase env sc' alts
|
||||||
| Just v => pure v
|
| Just v => pure v
|
||||||
|
|
||||||
vsc <- eval env sc
|
vsc <- eval env sc
|
||||||
alts' <- traverse (evalAlt env) alts
|
pure $ VCase fc vsc env alts
|
||||||
pure $ VCase fc vsc alts'
|
|
||||||
|
|
||||||
quote : (lvl : Int) -> Val -> M Tm
|
quote : (lvl : Int) -> Val -> M Tm
|
||||||
|
|
||||||
@@ -210,10 +196,14 @@ quoteSp lvl t (xs :< x) = do
|
|||||||
x' <- quote lvl x
|
x' <- quote lvl x
|
||||||
pure $ App emptyFC t' x'
|
pure $ App emptyFC t' x'
|
||||||
|
|
||||||
quoteAlt : Int → VCaseAlt → M CaseAlt
|
normAlt : Env → Int → CaseAlt → M CaseAlt
|
||||||
quoteAlt l (VCaseDefault val) = CaseDefault <$> quote l val
|
normAlt env l (CaseDefault tm) = do
|
||||||
quoteAlt l (VCaseLit lit val) = CaseLit lit <$> quote l val
|
val <- eval env tm
|
||||||
quoteAlt l (VCaseCons nm args env tm) = do
|
CaseDefault <$> quote l val
|
||||||
|
normAlt env l (CaseLit lit tm) = do
|
||||||
|
val <- eval env tm
|
||||||
|
CaseLit lit <$> quote l val
|
||||||
|
normAlt env l (CaseCons nm args tm) = do
|
||||||
val <- eval (mkenv l env args) tm
|
val <- eval (mkenv l env args) tm
|
||||||
tm <- quote (length' args + l) val
|
tm <- quote (length' args + l) val
|
||||||
pure $ CaseCons nm args tm
|
pure $ CaseCons nm args tm
|
||||||
@@ -224,7 +214,7 @@ quoteAlt l (VCaseCons nm args env tm) = do
|
|||||||
|
|
||||||
quote l (VVar fc k sp) = if k < l
|
quote l (VVar fc k sp) = if k < l
|
||||||
then quoteSp l (Bnd fc (lvl2ix l k )) sp -- level to index
|
then quoteSp l (Bnd fc (lvl2ix l k )) sp -- level to index
|
||||||
else error fc "Bad index in quote \{show k} depth \{show l}"
|
else error fc "Bad level in quote \{show k} depth \{show l}"
|
||||||
quote l (VMeta fc i sp) = do
|
quote l (VMeta fc i sp) = do
|
||||||
meta <- lookupMeta i
|
meta <- lookupMeta i
|
||||||
case meta of
|
case meta of
|
||||||
@@ -241,6 +231,7 @@ quote l (VPi fc x icit rig a b) = do
|
|||||||
pure $ Pi fc x icit rig a' tm
|
pure $ Pi fc x icit rig a' tm
|
||||||
quote l (VLet fc nm t u) = do
|
quote l (VLet fc nm t u) = do
|
||||||
t' <- quote l t
|
t' <- quote l t
|
||||||
|
u <- u $$ VVar fc l Lin
|
||||||
u' <- quote (1 + l) u
|
u' <- quote (1 + l) u
|
||||||
pure $ Let fc nm t' u'
|
pure $ Let fc nm t' u'
|
||||||
quote l (VLetRec fc nm ty t u) = do
|
quote l (VLetRec fc nm ty t u) = do
|
||||||
@@ -250,10 +241,11 @@ quote l (VLetRec fc nm ty t u) = do
|
|||||||
pure $ LetRec fc nm ty' t' u'
|
pure $ LetRec fc nm ty' t' u'
|
||||||
quote l (VU fc) = pure (UU fc)
|
quote l (VU fc) = pure (UU fc)
|
||||||
quote l (VRef fc n sp) = quoteSp l (Ref fc n) sp
|
quote l (VRef fc n sp) = quoteSp l (Ref fc n) sp
|
||||||
quote l (VCase fc sc valts) = do
|
quote l (VCase fc sc env alts) = do
|
||||||
sc' <- quote l sc
|
sc' <- quote l sc
|
||||||
alts <- traverse (quoteAlt l) valts
|
alts' <- traverse (normAlt env l) alts
|
||||||
pure $ Case fc sc' alts
|
pure $ Case fc sc' alts'
|
||||||
|
|
||||||
quote l (VLit fc lit) = pure $ Lit fc lit
|
quote l (VLit fc lit) = pure $ Lit fc lit
|
||||||
quote l (VErased fc) = pure $ Erased fc
|
quote l (VErased fc) = pure $ Erased fc
|
||||||
|
|
||||||
@@ -268,7 +260,6 @@ prvalCtx {{ctx}} v = do
|
|||||||
tm <- quote ctx.lvl v
|
tm <- quote ctx.lvl v
|
||||||
pure $ render 90 $ pprint (map fst ctx.types) tm
|
pure $ render 90 $ pprint (map fst ctx.types) tm
|
||||||
|
|
||||||
|
|
||||||
-- 'zonk' is substituting metas _and_ doing inlining
|
-- 'zonk' is substituting metas _and_ doing inlining
|
||||||
|
|
||||||
-- It is a flavor of eval, maybe we could combine them with some flags
|
-- It is a flavor of eval, maybe we could combine them with some flags
|
||||||
@@ -309,23 +300,37 @@ zonkApp top l env t@(Meta fc k) sp = do
|
|||||||
meta <- lookupMeta k
|
meta <- lookupMeta k
|
||||||
case meta of
|
case meta of
|
||||||
(Solved _ j v) => do
|
(Solved _ j v) => do
|
||||||
|
debug $ \ _ => "zonk for \{show k} env \{show env}"
|
||||||
|
debug $ \ _ => "spine \{show sp}"
|
||||||
sp' <- traverse (eval env) sp
|
sp' <- traverse (eval env) sp
|
||||||
debug $ \ _ => "zonk \{show k} -> \{show v} spine \{show sp'}"
|
debug $ \ _ => "zonk meta \{show k} -> \{show v} spine \{show sp'}"
|
||||||
foo <- vappSpine v (Lin <>< sp')
|
foo <- vappSpine v (Lin <>< sp')
|
||||||
debug $ \ _ => "-> result is \{show foo}"
|
debug $ \ _ => "-> result is \{show foo}"
|
||||||
tweakFC fc <$> quote l foo
|
if length' env /= l
|
||||||
|
then fatalError "MM2 \{show l} /= \{show $ length' env}"
|
||||||
|
else pure MkUnit
|
||||||
|
res <- tweakFC fc <$> quote l foo
|
||||||
|
debug $ \ _ => "quoted \{show res}"
|
||||||
|
pure res
|
||||||
_ => pure $ appSpine t sp
|
_ => pure $ appSpine t sp
|
||||||
zonkApp top l env t sp = do
|
zonkApp top l env t sp = do
|
||||||
|
debug $ \ _ => "zonk2 for \{show t} env \{show env}"
|
||||||
|
debug $ \ _ => "spine \{show sp}"
|
||||||
t' <- zonk top l env t
|
t' <- zonk top l env t
|
||||||
-- inlining
|
-- inlining
|
||||||
let (Just tm) = inlineDef t' | _ => pure $ appSpine t' sp
|
let (Just tm) = inlineDef t' | _ => pure $ appSpine t' sp
|
||||||
sp' <- traverse (eval env) sp
|
sp' <- traverse (eval env) sp
|
||||||
vtm <- eval env tm
|
vtm <- eval env tm
|
||||||
catchError (do
|
catchError (do
|
||||||
foo <- vappSpine vtm (Lin <>< sp')
|
debug $ \ _ => "zonk will app \{show t'} @ \{show sp} ~> \{show vtm} @ \{show sp'}"
|
||||||
t' <- quote l foo
|
res <- vappSpine vtm (Lin <>< sp')
|
||||||
zonk top l env t')
|
debug $ \_ => "result is \{show res}"
|
||||||
(\_ => pure $ appSpine t' sp)
|
t' <- quote l res
|
||||||
|
x <- zonk top l env t'
|
||||||
|
pure x)
|
||||||
|
(\err => do
|
||||||
|
debug $ \_ => "result err \{showError "" err}"
|
||||||
|
pure $ appSpine t' sp)
|
||||||
where
|
where
|
||||||
-- lookup name and return Def if flagged inline
|
-- lookup name and return Def if flagged inline
|
||||||
inlineDef : Tm → Maybe Tm
|
inlineDef : Tm → Maybe Tm
|
||||||
|
|||||||
@@ -28,7 +28,7 @@ parenWrap pa = do
|
|||||||
pure t
|
pure t
|
||||||
|
|
||||||
braces : ∀ a. Parser a -> Parser a
|
braces : ∀ a. Parser a -> Parser a
|
||||||
braces pa = do
|
braces pa = try $ do
|
||||||
symbol "{"
|
symbol "{"
|
||||||
t <- pa
|
t <- pa
|
||||||
symbol "}"
|
symbol "}"
|
||||||
@@ -107,9 +107,17 @@ asAtom = do
|
|||||||
Just exp => pure $ RAs fc nm exp
|
Just exp => pure $ RAs fc nm exp
|
||||||
Nothing => pure $ RVar fc nm
|
Nothing => pure $ RVar fc nm
|
||||||
|
|
||||||
-- the inside of Raw
|
|
||||||
recordUpdate : Parser Raw
|
recordUpdate : Parser Raw
|
||||||
|
|
||||||
|
listTypeExp : Parser Raw
|
||||||
|
listTypeExp = do
|
||||||
|
fc <- getPos
|
||||||
|
symbol "["
|
||||||
|
tm <- optional typeExpr
|
||||||
|
symbol "]"
|
||||||
|
pure $ RList fc tm
|
||||||
|
|
||||||
parenTypeExp : Parser Raw
|
parenTypeExp : Parser Raw
|
||||||
parenTypeExp = do
|
parenTypeExp = do
|
||||||
fc <- getPos
|
fc <- getPos
|
||||||
@@ -126,6 +134,7 @@ atom : Parser Raw
|
|||||||
atom = do
|
atom = do
|
||||||
pure MkUnit
|
pure MkUnit
|
||||||
RU <$> getPos <* keyword "U"
|
RU <$> getPos <* keyword "U"
|
||||||
|
<|> recordUpdate
|
||||||
-- <|> RVar <$> getPos <*> ident
|
-- <|> RVar <$> getPos <*> ident
|
||||||
<|> asAtom
|
<|> asAtom
|
||||||
<|> RVar <$> getPos <*> uident
|
<|> RVar <$> getPos <*> uident
|
||||||
@@ -133,8 +142,8 @@ atom = do
|
|||||||
<|> lit
|
<|> lit
|
||||||
<|> RImplicit <$> getPos <* keyword "_"
|
<|> RImplicit <$> getPos <* keyword "_"
|
||||||
<|> RHole <$> getPos <* keyword "?"
|
<|> RHole <$> getPos <* keyword "?"
|
||||||
|
<|> listTypeExp
|
||||||
<|> parenTypeExp
|
<|> parenTypeExp
|
||||||
<|> recordUpdate
|
|
||||||
|
|
||||||
updateClause : Parser UpdateClause
|
updateClause : Parser UpdateClause
|
||||||
updateClause = do
|
updateClause = do
|
||||||
@@ -146,15 +155,15 @@ updateClause = do
|
|||||||
True => pure $ AssignField fc nm tm
|
True => pure $ AssignField fc nm tm
|
||||||
_ => pure $ ModifyField fc nm tm
|
_ => pure $ ModifyField fc nm tm
|
||||||
|
|
||||||
-- ambiguity vs {a} or {a} -> ... is tough, we can do [] or put a keyword in front.
|
|
||||||
recordUpdate = do
|
recordUpdate = do
|
||||||
fc <- getPos
|
fc <- getPos
|
||||||
symbol "["
|
symbol "{"
|
||||||
clauses <- sepBy (symbol ";") updateClause
|
clauses <- sepBy (symbol ";") updateClause
|
||||||
symbol "]"
|
symbol "}"
|
||||||
tm <- optional atom
|
tm <- optional atom
|
||||||
pure $ RUpdateRec fc clauses tm
|
pure $ RUpdateRec fc clauses tm
|
||||||
|
|
||||||
|
|
||||||
-- Argument to a Spine
|
-- Argument to a Spine
|
||||||
pArg : Parser (Icit × FC × Raw)
|
pArg : Parser (Icit × FC × Raw)
|
||||||
pArg = do
|
pArg = do
|
||||||
@@ -454,11 +463,14 @@ ebind = do
|
|||||||
|
|
||||||
ibind : Parser Telescope
|
ibind : Parser Telescope
|
||||||
ibind = do
|
ibind = do
|
||||||
-- I've gone back and forth on this, but I think {m a b} is more useful than {Int}
|
-- we don't know if it's an ibind or record update until we hit the `:`
|
||||||
|
(quant, names) <- try $ do
|
||||||
symbol "{"
|
symbol "{"
|
||||||
quant <- quantity
|
quant <- quantity
|
||||||
names <- (some (addPos varname))
|
names <- (some (addPos varname))
|
||||||
ty <- symbol ":" *> typeExpr
|
symbol ":"
|
||||||
|
pure (quant, names)
|
||||||
|
ty <- typeExpr
|
||||||
symbol "}"
|
symbol "}"
|
||||||
pure $ map (makeBind quant (Just ty)) names
|
pure $ map (makeBind quant (Just ty)) names
|
||||||
where
|
where
|
||||||
|
|||||||
@@ -310,6 +310,7 @@ processInstance ns instfc ty decls = do
|
|||||||
vdcty@(VPi _ nm icit rig a b) <- eval Nil dcty
|
vdcty@(VPi _ nm icit rig a b) <- eval Nil dcty
|
||||||
| x => error (getFC x) "dcty not Pi"
|
| x => error (getFC x) "dcty not Pi"
|
||||||
debug $ \ _ => "dcty \{render 90 $ pprint Nil dcty}"
|
debug $ \ _ => "dcty \{render 90 $ pprint Nil dcty}"
|
||||||
|
-- let (_,args) = funArgs codomain
|
||||||
|
|
||||||
debug $ \ _ => "traverse \{show $ map show args}"
|
debug $ \ _ => "traverse \{show $ map show args}"
|
||||||
-- This is a little painful because we're reverse engineering the
|
-- This is a little painful because we're reverse engineering the
|
||||||
@@ -546,9 +547,6 @@ processRecord ns recordFC (nameFC, nm) tele cname decls = do
|
|||||||
processFields : Raw → Raw → List (String × Raw) → List (FC × String × Raw) → M Unit
|
processFields : Raw → Raw → List (String × Raw) → List (FC × String × Raw) → M Unit
|
||||||
processFields _ _ _ Nil = pure MkUnit
|
processFields _ _ _ Nil = pure MkUnit
|
||||||
processFields autoPat tail deps ((fc,name,ty) :: rest) = do
|
processFields autoPat tail deps ((fc,name,ty) :: rest) = do
|
||||||
-- TODO dependency isn't handled yet
|
|
||||||
-- we'll need to replace stuff like `len` with `len self`.
|
|
||||||
|
|
||||||
let funType = substRaw deps $ teleToPi (impTele tele) $ RPi fc (BI fc "$self" Explicit Many) tail ty
|
let funType = substRaw deps $ teleToPi (impTele tele) $ RPi fc (BI fc "$self" Explicit Many) tail ty
|
||||||
|
|
||||||
-- `.fieldName`
|
-- `.fieldName`
|
||||||
|
|||||||
@@ -17,13 +17,13 @@ import Lib.Elab
|
|||||||
-- declare internal primitives
|
-- declare internal primitives
|
||||||
addPrimitives : M ModContext
|
addPrimitives : M ModContext
|
||||||
addPrimitives = do
|
addPrimitives = do
|
||||||
modifyTop [ currentMod := emptyModCtx "Prim" ""; hints := emptyMap; ops := emptyMap ]
|
modifyTop { currentMod := emptyModCtx "Prim" ""; hints := emptyMap; ops := emptyMap }
|
||||||
processDecl primNS (PType emptyFC "Int" Nothing)
|
processDecl primNS (PType emptyFC "Int" Nothing)
|
||||||
processDecl primNS (PType emptyFC "String" Nothing)
|
processDecl primNS (PType emptyFC "String" Nothing)
|
||||||
processDecl primNS (PType emptyFC "Char" 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
|
setDef (QN primNS "PiType") emptyFC (Erased emptyFC) (PrimFn "(h0, h1) => ({ tag: \"PiType\", h0, h1 });" (S (S Z)) Nil) Nil
|
||||||
top <- getTop
|
top <- getTop
|
||||||
modifyTop [ modules $= updateMap primNS top.currentMod ]
|
modifyTop { modules $= updateMap primNS top.currentMod }
|
||||||
pure top.currentMod
|
pure top.currentMod
|
||||||
|
|
||||||
record FileSource where
|
record FileSource where
|
||||||
@@ -74,12 +74,12 @@ processModule importFC repo stk modns = do
|
|||||||
|
|
||||||
-- Dummy for initial load/parse
|
-- Dummy for initial load/parse
|
||||||
let mod = MkModCtx modns "" emptyMap freshMC emptyMap Nil Nil Nil
|
let mod = MkModCtx modns "" emptyMap freshMC emptyMap Nil Nil Nil
|
||||||
modifyTop [ currentMod := mod; hints := emptyMap; ops := emptyMap ]
|
modifyTop { currentMod := mod; hints := emptyMap; ops := emptyMap }
|
||||||
|
|
||||||
-- TODO now we can pass in the module name...
|
-- TODO now we can pass in the module name...
|
||||||
Right (fn,src) <- tryError $ repo.getFile importFC fn
|
Right (fn,src) <- tryError $ repo.getFile importFC fn
|
||||||
| Left err => reportError err -- TODO maybe want a better FC.
|
| Left err => reportError err -- TODO maybe want a better FC.
|
||||||
modifyTop [ currentMod $= [ modSource := src ]]
|
modifyTop { currentMod $= { modSource := src }}
|
||||||
|
|
||||||
let (Right toks) = tokenise fn src
|
let (Right toks) = tokenise fn src
|
||||||
| Left err => reportError err
|
| Left err => reportError err
|
||||||
@@ -108,10 +108,10 @@ processModule importFC repo stk modns = do
|
|||||||
-- currentMod has been wiped by imports..
|
-- currentMod has been wiped by imports..
|
||||||
let freshMC = MC emptyMap Nil 0 CheckAll
|
let freshMC = MC emptyMap Nil 0 CheckAll
|
||||||
let mod = MkModCtx modns src emptyMap freshMC emptyMap imported Nil Nil
|
let mod = MkModCtx modns src emptyMap freshMC emptyMap imported Nil Nil
|
||||||
modifyTop [ currentMod := mod
|
modifyTop { currentMod := mod
|
||||||
; hints := emptyMap
|
; hints := emptyMap
|
||||||
; ops := ops
|
; ops := ops
|
||||||
]
|
}
|
||||||
|
|
||||||
-- top hints / ops include all directly imported modules
|
-- top hints / ops include all directly imported modules
|
||||||
top <- getTop
|
top <- getTop
|
||||||
@@ -119,7 +119,7 @@ processModule importFC repo stk modns = do
|
|||||||
(MkImport fc (nameFC, ns)) => do
|
(MkImport fc (nameFC, ns)) => do
|
||||||
let (Just mod) = lookupMap' ns top.modules | _ => error emptyFC "namespace \{show ns} missing"
|
let (Just mod) = lookupMap' ns top.modules | _ => error emptyFC "namespace \{show ns} missing"
|
||||||
importHints (listValues mod.modDefs)
|
importHints (listValues mod.modDefs)
|
||||||
modifyTop [ ops $= mergeOps mod.modOps ]
|
modifyTop { ops $= mergeOps mod.modOps }
|
||||||
|
|
||||||
-- add error if an import contains an error
|
-- add error if an import contains an error
|
||||||
-- maybe move this to after reporting
|
-- maybe move this to after reporting
|
||||||
@@ -135,7 +135,7 @@ processModule importFC repo stk modns = do
|
|||||||
-- aside from reworking parsing, we could filter
|
-- aside from reworking parsing, we could filter
|
||||||
-- other options are removing updates from parsing (so we must use incremental parsing)
|
-- other options are removing updates from parsing (so we must use incremental parsing)
|
||||||
-- or removing pratt from parsing (so it happens in elaboration)
|
-- or removing pratt from parsing (so it happens in elaboration)
|
||||||
modifyTop [ currentMod $= [ modOps := ops ] ]
|
modifyTop { currentMod $= { modOps := ops } }
|
||||||
|
|
||||||
log 1 $ \ _ => "process Decls"
|
log 1 $ \ _ => "process Decls"
|
||||||
traverse (tryProcessDecl src modns) (collectDecl decls)
|
traverse (tryProcessDecl src modns) (collectDecl decls)
|
||||||
@@ -151,7 +151,7 @@ processModule importFC repo stk modns = do
|
|||||||
-- update modules with result, leave the rest of context in case this is top file
|
-- update modules with result, leave the rest of context in case this is top file
|
||||||
top <- getTop
|
top <- getTop
|
||||||
let modules = updateMap modns top.currentMod top.modules
|
let modules = updateMap modns top.currentMod top.modules
|
||||||
modifyTop [modules := modules]
|
modifyTop {modules := modules}
|
||||||
|
|
||||||
pure top.currentMod
|
pure top.currentMod
|
||||||
where
|
where
|
||||||
@@ -159,7 +159,7 @@ processModule importFC repo stk modns = do
|
|||||||
reportError err = do
|
reportError err = do
|
||||||
addError err
|
addError err
|
||||||
top <- getTop
|
top <- getTop
|
||||||
modifyTop [modules $= updateMap modns top.currentMod ]
|
modifyTop {modules $= updateMap modns top.currentMod }
|
||||||
pure top.currentMod
|
pure top.currentMod
|
||||||
|
|
||||||
tryProcessDecl : String → String → Decl → M Unit
|
tryProcessDecl : String → String → Decl → M Unit
|
||||||
@@ -174,7 +174,7 @@ invalidateModule modname = do
|
|||||||
let modules = join $ map getDeps $ toList top.modules
|
let modules = join $ map getDeps $ toList top.modules
|
||||||
let revMap = map swap modules
|
let revMap = map swap modules
|
||||||
let deps = foldl accumulate emptyMap revMap
|
let deps = foldl accumulate emptyMap revMap
|
||||||
modifyTop [ modules $= go deps (modname :: Nil) ]
|
modifyTop { modules $= go deps (modname :: Nil) }
|
||||||
where
|
where
|
||||||
accumulate : SortedMap String (List String) → String × String → SortedMap String (List String)
|
accumulate : SortedMap String (List String) → String × String → SortedMap String (List String)
|
||||||
accumulate deps (k,v) = let prev = fromMaybe Nil $ lookupMap' k deps
|
accumulate deps (k,v) = let prev = fromMaybe Nil $ lookupMap' k deps
|
||||||
|
|||||||
@@ -60,6 +60,7 @@ data Raw : U where
|
|||||||
-- has to be applied or we have to know its type as Foo → Foo to elaborate.
|
-- has to be applied or we have to know its type as Foo → Foo to elaborate.
|
||||||
-- I can bake the arg in here, or require an app in elab.
|
-- I can bake the arg in here, or require an app in elab.
|
||||||
RUpdateRec : (fc : FC) → List UpdateClause → Maybe Raw → Raw
|
RUpdateRec : (fc : FC) → List UpdateClause → Maybe Raw → Raw
|
||||||
|
RList : (fc : FC) → Maybe Raw → Raw
|
||||||
|
|
||||||
instance HasFC Raw where
|
instance HasFC Raw where
|
||||||
getFC (RVar fc nm) = fc
|
getFC (RVar fc nm) = fc
|
||||||
@@ -78,6 +79,7 @@ instance HasFC Raw where
|
|||||||
getFC (RAs fc _ _) = fc
|
getFC (RAs fc _ _) = fc
|
||||||
getFC (RUpdateRec fc _ _) = fc
|
getFC (RUpdateRec fc _ _) = fc
|
||||||
getFC (RImpossible fc) = fc
|
getFC (RImpossible fc) = fc
|
||||||
|
getFC (RList fc _) = fc
|
||||||
|
|
||||||
data Import = MkImport FC (FC × Name)
|
data Import = MkImport FC (FC × Name)
|
||||||
|
|
||||||
@@ -189,6 +191,8 @@ instance Pretty Raw where
|
|||||||
asDoc p (RWhere _ dd b) = text "TODO pretty RWhere"
|
asDoc p (RWhere _ dd b) = text "TODO pretty RWhere"
|
||||||
asDoc p (RAs _ nm x) = text nm ++ text "@(" ++ asDoc 0 x ++ text ")"
|
asDoc p (RAs _ nm x) = text nm ++ text "@(" ++ asDoc 0 x ++ text ")"
|
||||||
asDoc p (RUpdateRec _ clauses tm) = text "{" <+> text "TODO RUpdateRec" <+> text "}"
|
asDoc p (RUpdateRec _ clauses tm) = text "{" <+> text "TODO RUpdateRec" <+> text "}"
|
||||||
|
asDoc p (RList _ (Just t)) = text "[" <+> asDoc p t <+> text "]"
|
||||||
|
asDoc p (RList _ Nothing) = text "[]"
|
||||||
|
|
||||||
prettyBind : (BindInfo × Raw) -> Doc
|
prettyBind : (BindInfo × Raw) -> Doc
|
||||||
prettyBind (BI _ nm icit quant, ty) = wrap icit (text (show quant ++ nm) <+> text ":" <+> pretty ty)
|
prettyBind (BI _ nm icit quant, ty) = wrap icit (text (show quant ++ nm) <+> text ":" <+> pretty ty)
|
||||||
@@ -246,6 +250,8 @@ substRaw ss t = case t of
|
|||||||
(RWhere fc ds body) => RWhere fc (map substDecl ds) (substRaw ss body)
|
(RWhere fc ds body) => RWhere fc (map substDecl ds) (substRaw ss body)
|
||||||
(RDo fc stmts) => RDo fc (substStmts ss stmts)
|
(RDo fc stmts) => RDo fc (substStmts ss stmts)
|
||||||
(RCase fc scrut mdef alts) => RCase fc (substRaw ss scrut) (map (substRaw ss) mdef) (map substAlt alts)
|
(RCase fc scrut mdef alts) => RCase fc (substRaw ss scrut) (map (substRaw ss) mdef) (map substAlt alts)
|
||||||
|
(RList fc (Just t)) => RList fc (Just $ substRaw ss t)
|
||||||
|
(RList fc Nothing) => RList fc Nothing
|
||||||
-- Enumerate to force consideration of new cases
|
-- Enumerate to force consideration of new cases
|
||||||
t@(RImpossible _) => t
|
t@(RImpossible _) => t
|
||||||
t@(RU _) => t
|
t@(RU _) => t
|
||||||
|
|||||||
@@ -53,7 +53,7 @@ setFlag name fc flag = do
|
|||||||
top <- getTop
|
top <- getTop
|
||||||
let (Just (MkEntry fc nm ty def flags)) = lookupMap' name top.currentMod.modDefs
|
let (Just (MkEntry fc nm ty def flags)) = lookupMap' name top.currentMod.modDefs
|
||||||
| Nothing => error fc "\{show name} not declared"
|
| Nothing => error fc "\{show name} not declared"
|
||||||
modifyTop [ currentMod $= [ modDefs $= (updateMap name (MkEntry fc name ty def (flag :: flags)))] ]
|
modifyTop { currentMod $= { modDefs $= (updateMap name (MkEntry fc name ty def (flag :: flags)))} }
|
||||||
|
|
||||||
setDef : QName -> FC -> Tm -> Def → List EFlag -> M Unit
|
setDef : QName -> FC -> Tm -> Def → List EFlag -> M Unit
|
||||||
setDef name fc ty def flags = do
|
setDef name fc ty def flags = do
|
||||||
@@ -61,14 +61,14 @@ setDef name fc ty def flags = do
|
|||||||
let (Nothing) = lookupMap' name top.currentMod.modDefs
|
let (Nothing) = lookupMap' name top.currentMod.modDefs
|
||||||
| Just (MkEntry fc' nm' ty' def' _) => error fc "\{show name} is already defined at \{show fc'}"
|
| Just (MkEntry fc' nm' ty' def' _) => error fc "\{show name} is already defined at \{show fc'}"
|
||||||
|
|
||||||
modifyTop [currentMod $= [ modDefs $= (updateMap name (MkEntry fc name ty def flags))] ]
|
modifyTop {currentMod $= { modDefs $= (updateMap name (MkEntry fc name ty def flags))} }
|
||||||
|
|
||||||
updateDef : QName -> FC -> Tm -> Def -> M Unit
|
updateDef : QName -> FC -> Tm -> Def -> M Unit
|
||||||
updateDef name fc ty def = do
|
updateDef name fc ty def = do
|
||||||
top <- getTop
|
top <- getTop
|
||||||
let (Just (MkEntry fc' nm' ty' def' flags)) = lookupMap' name top.currentMod.modDefs
|
let (Just (MkEntry fc' nm' ty' def' flags)) = lookupMap' name top.currentMod.modDefs
|
||||||
| Nothing => error fc "\{show name} not declared"
|
| Nothing => error fc "\{show name} not declared"
|
||||||
modifyTop [ currentMod $= [ modDefs := updateMap name (MkEntry fc' name ty def flags) top.currentMod.modDefs ] ]
|
modifyTop { currentMod $= { modDefs := updateMap name (MkEntry fc' name ty def flags) top.currentMod.modDefs } }
|
||||||
|
|
||||||
typeName : Tm → Maybe QName
|
typeName : Tm → Maybe QName
|
||||||
typeName (Pi fc nm Explicit rig t u) = Nothing
|
typeName (Pi fc nm Explicit rig t u) = Nothing
|
||||||
@@ -86,18 +86,18 @@ addHint qn = do
|
|||||||
| Nothing => error entry.fc "can't find tcon name for \{show qn}"
|
| Nothing => error entry.fc "can't find tcon name for \{show qn}"
|
||||||
let xs = fromMaybe Nil $ lookupMap' tyname top.hints
|
let xs = fromMaybe Nil $ lookupMap' tyname top.hints
|
||||||
let hints = updateMap tyname ((qn, entry.type) :: xs) top.hints
|
let hints = updateMap tyname ((qn, entry.type) :: xs) top.hints
|
||||||
modifyTop [ hints := hints ]
|
modifyTop { hints := hints }
|
||||||
Nothing => pure MkUnit
|
Nothing => pure MkUnit
|
||||||
|
|
||||||
addError : Error -> M Unit
|
addError : Error -> M Unit
|
||||||
addError err = modifyTop [ currentMod $= [ modErrors $= (err ::) ] ]
|
addError err = modifyTop { currentMod $= { modErrors $= (err ::) } }
|
||||||
|
|
||||||
addInfo : EditorInfo → M Unit
|
addInfo : EditorInfo → M Unit
|
||||||
addInfo info = modifyTop [ currentMod $= [modInfos $= (info ::) ] ]
|
addInfo info = modifyTop { currentMod $= {modInfos $= (info ::) } }
|
||||||
|
|
||||||
-- temporary? used in derive for now
|
-- temporary? used in derive for now
|
||||||
freshName : String → M String
|
freshName : String → M String
|
||||||
freshName nm = do
|
freshName nm = do
|
||||||
top <- getTop
|
top <- getTop
|
||||||
modifyTop [ freshIx $= 1 + ]
|
modifyTop { freshIx $= 1 + }
|
||||||
pure $ "f$" ++ nm ++ show top.freshIx
|
pure $ "f$" ++ nm ++ show top.freshIx
|
||||||
|
|||||||
@@ -23,7 +23,10 @@ derive Show BD
|
|||||||
|
|
||||||
data Quant = Zero | Many
|
data Quant = Zero | Many
|
||||||
derive Eq Quant
|
derive Eq Quant
|
||||||
derive Show Quant
|
|
||||||
|
instance Show Quant where
|
||||||
|
show Zero = "0 "
|
||||||
|
show Many = ""
|
||||||
|
|
||||||
-- We could make this polymorphic and use for environment...
|
-- We could make this polymorphic and use for environment...
|
||||||
|
|
||||||
@@ -169,20 +172,15 @@ Val : U
|
|||||||
Closure : U
|
Closure : U
|
||||||
Env : U
|
Env : U
|
||||||
|
|
||||||
data VCaseAlt : U where
|
|
||||||
-- Like a Closure, but with a lot of args
|
|
||||||
VCaseCons : (name : QName) -> (args : List String) -> Env -> Tm -> VCaseAlt
|
|
||||||
VCaseLit : Literal -> Val -> VCaseAlt
|
|
||||||
VCaseDefault : Val -> VCaseAlt
|
|
||||||
|
|
||||||
data Val : U where
|
data Val : U where
|
||||||
VVar : FC -> (k : Int) -> (sp : SnocList Val) -> Val
|
VVar : FC -> (k : Int) -> (sp : SnocList Val) -> Val
|
||||||
VRef : FC -> (nm : QName) -> (sp : SnocList Val) -> Val
|
VRef : FC -> (nm : QName) -> (sp : SnocList Val) -> Val
|
||||||
VCase : FC -> (sc : Val) -> List VCaseAlt -> Val
|
VCase : FC -> (sc : Val) -> Env -> List CaseAlt -> Val
|
||||||
VMeta : FC -> QName -> (sp : SnocList Val) -> Val
|
VMeta : FC -> QName -> (sp : SnocList Val) -> Val
|
||||||
VLam : FC -> Name -> Icit -> Quant -> Closure -> Val
|
VLam : FC -> Name -> Icit -> Quant -> Closure -> Val
|
||||||
VPi : FC -> Name -> Icit -> Quant -> (a : Val) -> (b : Closure) -> Val
|
VPi : FC -> Name -> Icit -> Quant -> (a : Val) -> (b : Closure) -> Val
|
||||||
VLet : FC -> Name -> Val -> Val -> Val
|
-- not substing let, like idris
|
||||||
|
VLet : FC -> Name -> Val -> Closure -> Val
|
||||||
VLetRec : FC -> Name -> Val -> Val -> Val -> Val
|
VLetRec : FC -> Name -> Val -> Val -> Val -> Val
|
||||||
VU : FC -> Val
|
VU : FC -> Val
|
||||||
VErased : FC -> Val
|
VErased : FC -> Val
|
||||||
@@ -196,7 +194,7 @@ data Closure = MkClosure Env Tm
|
|||||||
getValFC : Val -> FC
|
getValFC : Val -> FC
|
||||||
getValFC (VVar fc _ _) = fc
|
getValFC (VVar fc _ _) = fc
|
||||||
getValFC (VRef fc _ _) = fc
|
getValFC (VRef fc _ _) = fc
|
||||||
getValFC (VCase fc _ _) = fc
|
getValFC (VCase fc _ _ _) = fc
|
||||||
getValFC (VMeta fc _ _) = fc
|
getValFC (VMeta fc _ _) = fc
|
||||||
getValFC (VLam fc _ _ _ _) = fc
|
getValFC (VLam fc _ _ _ _) = fc
|
||||||
getValFC (VPi fc _ _ _ a b) = fc
|
getValFC (VPi fc _ _ _ a b) = fc
|
||||||
@@ -220,15 +218,10 @@ instance Show Val where
|
|||||||
show (VPi fc str Implicit rig x y) = "(%pi {\{show rig} \{str} : \{show x}}. \{showClosure y})"
|
show (VPi fc str Implicit rig x y) = "(%pi {\{show rig} \{str} : \{show x}}. \{showClosure y})"
|
||||||
show (VPi fc str Explicit rig x y) = "(%pi (\{show rig} \{str} : \{show x}). \{showClosure y})"
|
show (VPi fc str Explicit rig x y) = "(%pi (\{show rig} \{str} : \{show x}). \{showClosure y})"
|
||||||
show (VPi fc str Auto rig x y) = "(%pi {{\{show rig} \{str} : \{show x}}}. \{showClosure y})"
|
show (VPi fc str Auto rig x y) = "(%pi {{\{show rig} \{str} : \{show x}}}. \{showClosure y})"
|
||||||
show (VCase fc sc alts) = "(%case \{show sc} \{unwords $ map showAlt alts})"
|
show (VCase fc sc env alts) = "(%case \{show sc} \{unwords $ map show alts})"
|
||||||
where
|
|
||||||
showAlt : VCaseAlt → String
|
|
||||||
showAlt (VCaseDefault v) = "(%cdef \{show v})"
|
|
||||||
showAlt (VCaseLit lit v) = "(%clit \{show v})"
|
|
||||||
showAlt (VCaseCons nm args env v) = "(%ccon \{show nm} \{unwords $ map show args} [\{show $ length env} env] \{show v}"
|
|
||||||
show (VU _) = "U"
|
show (VU _) = "U"
|
||||||
show (VLit _ lit) = show lit
|
show (VLit _ lit) = show lit
|
||||||
show (VLet _ nm a b) = "(%let \{show nm} = \{show a} in \{show b}"
|
show (VLet _ nm a (MkClosure env b)) = "(%let \{show nm} = \{show a} in \{show b}"
|
||||||
show (VLetRec _ nm ty a b) = "(%letrec \{show nm} : \{show ty} = \{show a} in \{show b}"
|
show (VLetRec _ nm ty a b) = "(%letrec \{show nm} : \{show ty} = \{show a} in \{show b}"
|
||||||
show (VErased _) = "ERASED"
|
show (VErased _) = "ERASED"
|
||||||
|
|
||||||
@@ -269,7 +262,10 @@ record MetaContext where
|
|||||||
|
|
||||||
derive Eq MetaMode
|
derive Eq MetaMode
|
||||||
|
|
||||||
data ConInfo = NormalCon | SuccCon | ZeroCon | EnumCon | TrueCon | FalseCon | NilCon | ConsCon
|
data ConInfo = NormalCon
|
||||||
|
| SuccCon | ZeroCon
|
||||||
|
| EnumCon | TrueCon | FalseCon
|
||||||
|
| NilCon | ConsCon
|
||||||
|
|
||||||
derive Eq ConInfo
|
derive Eq ConInfo
|
||||||
|
|
||||||
|
|||||||
@@ -114,7 +114,7 @@ cmdLine : List String -> M (Maybe String × List String)
|
|||||||
cmdLine Nil = pure (Nothing, Nil)
|
cmdLine Nil = pure (Nothing, Nil)
|
||||||
cmdLine ("--top" :: args) = cmdLine args -- handled later
|
cmdLine ("--top" :: args) = cmdLine args -- handled later
|
||||||
cmdLine ("-v" :: args) = do
|
cmdLine ("-v" :: args) = do
|
||||||
modifyTop [ verbose $= _+_ 1 ]
|
modifyTop { verbose $= _+_ 1 }
|
||||||
cmdLine args
|
cmdLine args
|
||||||
cmdLine ("-o" :: fn :: args) = do
|
cmdLine ("-o" :: fn :: args) = do
|
||||||
(out, files) <- cmdLine args
|
(out, files) <- cmdLine args
|
||||||
@@ -166,8 +166,8 @@ runCommand (Load fn) = processFile fn
|
|||||||
runCommand (HelpCmd) = replHelp
|
runCommand (HelpCmd) = replHelp
|
||||||
runCommand (BrowseCmd qn) = browseTop qn
|
runCommand (BrowseCmd qn) = browseTop qn
|
||||||
runCommand (GetDoc name) = getDoc name
|
runCommand (GetDoc name) = getDoc name
|
||||||
runCommand (Verbose Nothing) = modifyTop [ verbose $= _+_ 1 ]
|
runCommand (Verbose Nothing) = modifyTop { verbose $= _+_ 1 }
|
||||||
runCommand (Verbose (Just v)) = modifyTop [ verbose := v ]
|
runCommand (Verbose (Just v)) = modifyTop { verbose := v }
|
||||||
runCommand (OutputJS fn) = writeSource fn
|
runCommand (OutputJS fn) = writeSource fn
|
||||||
runCommand DumpTop = do
|
runCommand DumpTop = do
|
||||||
json <- jsonTopContext
|
json <- jsonTopContext
|
||||||
|
|||||||
19
tests/ListSugar.newt
Normal file
19
tests/ListSugar.newt
Normal file
@@ -0,0 +1,19 @@
|
|||||||
|
module ListSugar
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
|
||||||
|
blah : List Int
|
||||||
|
blah = [ 1, 2, 3]
|
||||||
|
|
||||||
|
bar : List Int → Int
|
||||||
|
bar [ ] = 0
|
||||||
|
bar [x] = 1
|
||||||
|
bar _ = 42
|
||||||
|
|
||||||
|
main : IO Unit
|
||||||
|
main = do
|
||||||
|
printLn blah
|
||||||
|
printLn $ bar []
|
||||||
|
printLn $ bar [ 42 ]
|
||||||
|
printLn $ bar blah
|
||||||
4
tests/ListSugar.newt.golden
Normal file
4
tests/ListSugar.newt.golden
Normal file
@@ -0,0 +1,4 @@
|
|||||||
|
[1, 2, 3]
|
||||||
|
0
|
||||||
|
1
|
||||||
|
42
|
||||||
@@ -9,4 +9,4 @@ record Bar where
|
|||||||
foo : Foo
|
foo : Foo
|
||||||
|
|
||||||
blah : Bar → Bar
|
blah : Bar → Bar
|
||||||
blah x = [ foo $= [ bar := 1]] x
|
blah x = { foo $= { bar := 1}} x
|
||||||
|
|||||||
@@ -8,12 +8,12 @@ record Foo where
|
|||||||
baz : Nat
|
baz : Nat
|
||||||
|
|
||||||
blah : Foo → Foo
|
blah : Foo → Foo
|
||||||
blah x = [ bar := Z ] x
|
blah x = { bar := Z } x
|
||||||
|
|
||||||
main : IO Unit
|
main : IO Unit
|
||||||
main = do
|
main = do
|
||||||
let x = blah $ MkFoo (S Z) (S (S Z))
|
let x = blah $ MkFoo (S Z) (S (S Z))
|
||||||
printLn x.bar
|
printLn x.bar
|
||||||
-- this is unfortunate, it can't get record type from a meta
|
-- this is unfortunate, it can't get record type from a meta
|
||||||
let x' = the Foo $ [ baz := Z ] x
|
let x' = the Foo $ { baz := Z } x
|
||||||
printLn x'.baz
|
printLn x'.baz
|
||||||
|
|||||||
Reference in New Issue
Block a user