unification seems to work for kovacs examples

This commit is contained in:
2024-07-13 09:32:49 -07:00
parent b37fa56c70
commit 76fae34bcf
11 changed files with 219 additions and 136 deletions

View File

@@ -1,5 +1,5 @@
Parser is in place. Parser is in place.
Ditched well-scoped for now. Ditched well-scoped for now.
Fixed more issues, started processing stuff, we need real example code. Fixed more issues, started processing stuff, we need real example code.
@@ -12,45 +12,65 @@ So smalltt has TopVar with a Level. typechecking binders end up as top too.
Also delayed unfolded values for top or solved metas. This looks like glue - all the bits for the top and a cached value (it's keeping top as values). Also delayed unfolded values for top or solved metas. This looks like glue - all the bits for the top and a cached value (it's keeping top as values).
We need metas next. SmallTT has a metactx in context as a mutable array. REVIEW the delayed unfolding, we're being aggressive for now. This may have been necessary until unification was in place, now we can decide to further unfold during unification.
We extend the context and then drop it, so we need soemthing mutable. metas are assoc list, can probably just be list, but we'd need to do level/index math for the lookup.
It's in top context and he pulls stuff down to context as needed. I'm overthinking this. I'm reluctant to copy Idris because resolved names are not compatible with query based, but everybody is using an array... They are in separate MetaContext wrapped in an IORef. I'm reluctant to copy Idris because resolved names are not compatible with query based, but everybody is using an array...
I'd kinda like to see array run in js... Idris has a common array for metas and defs but that might be a problem if I go query based someday.
Idris does a common array for metas and defs. Prettier was missing a Lazy. I'm still fairly faithful to the paper, but might want to refactor that to push the computation down into the `if`.
Prettier was missing a Lazy. Zoo3 runs now, I had to fix meta / meta unification.
Zoo3, mostly runs aside from eqTest. I've added a bunch of info logs for the editor support.
Zoo4 examples run now.
Maybe do `data` next. There is a crude version in place, we'll want to fix that, typecheck the new stuff, and then add cases. (Maybe introduce eliminators.)
When I generate code, I'll eventually run up against the erased thing. (I'll want to erase some of the stuff that is compile time.) But we'll generate code and decide how far we need to take this. It's probably pointless to just reproduce Idris.
When I self host, I'll have to drop or implement typeclasses. I do understand auto enough to make it happen.
Ok, for code gen, I think I'll need something like primitive values and definitely primitive functions. For v0, I could leave the holes as undefined and if there is a function with that name, it's magically FFI.
Questions:
- [ ] Code gen or data next?
- [ ] Should I write this up properly?
Parser: Parser:
- [x] unify broken for zoo3 `cons`
- [ ] parser for block comments - [ ] parser for block comments
- [x] import statement - [x] import statement
- [x] def - [x] def
- [x] simple decl - [x] simple decl
- [x] List not in scope
Misc:
- [x] vscode support for .newt - [x] vscode support for .newt
- [ ] Should I switch this back over to the App monad?
- [x] Error object like pi-forall - [x] Error object like pi-forall
- [ ] Get implicits working - [ ] I think I'll need to go with non-generic error type once I need to do something other than print them
- [x] Get unification working (zoo3)
- [x] Get implicits working (zoo4)
- [x] Replace on define - [x] Replace on define
- [x] more sugar on lambdas - [x] more sugar on lambdas
- [ ] tests for parsing and pretty printing - [ ] tests for parsing and pretty printing
- [ ] white box tests for internals
- Maybe look at narya for examples of what I should be testing
- [ ] inductive types - [ ] inductive types
- [ ] read data definitions 1/2 done - read data definitions 1/2 done
- [x] read files - [x] read files
- [x] process a file - [x] process a file
- [x] figure out context representation - Global context? - [x] figure out context representation - Global context?
- [x] type checking / elab - [x] type checking / elab
- What does this represent? The basics, implicits? pattern unification? - What does this represent? The basics, implicits? pattern unification?
- [ ] symbolic execution - [ ] symbolic execution
- why did I put this here? Is it just for `eval`? We do have CBN in place, we could eval inferrable
- [ ] compilation - [ ] compilation
- I'm thinking I get data working first
- [ ] write tests - [ ] write tests
- [ ] Split up code better
Forward: Forward:

View File

@@ -27,9 +27,9 @@ export function activate(context: vscode.ExtensionContext) {
for (let i = 0; i < lines.length; i++) { for (let i = 0; i < lines.length; i++) {
const line = lines[i]; const line = lines[i];
const match = line.match(/ERROR at \((\d+), (\d+)\): (.*)/); const match = line.match(/(INFO|ERROR) at \((\d+), (\d+)\): (.*)/);
if (match) { if (match) {
let [_full, line, column, message] = match; let [_full, kind, line, column, message] = match;
let lnum = Number(line); let lnum = Number(line);
let cnum = Number(column); let cnum = Number(column);
let start = new vscode.Position(lnum, cnum); let start = new vscode.Position(lnum, cnum);
@@ -47,7 +47,7 @@ export function activate(context: vscode.ExtensionContext) {
) { ) {
message += "\n" + lines[++i]; message += "\n" + lines[++i];
} }
const severity = vscode.DiagnosticSeverity.Error; const severity = kind === 'ERROR' ? vscode.DiagnosticSeverity.Error : vscode.DiagnosticSeverity.Information
const diag = new vscode.Diagnostic(range, message, severity); const diag = new vscode.Diagnostic(range, message, severity);
diagnostics.push(diag); diagnostics.push(diag);
} }

View File

@@ -54,23 +54,5 @@ hundred = mul ten ten
thousand : Nat thousand : Nat
thousand = mul ten hundred thousand = mul ten hundred
-- All of these fail, but are they funext? eqTest : Eq _ hundred hundred
-- works for zoo3, but maybe I'm expanding stuff too eagerly eqTest = refl _ _
-- eq : Eq _ true true
-- eq = refl
-- eqTest2 : Eq _ five five
-- eqTest2 = refl
-- -- This one breaks
-- eqTest : Eq _ hundred hundred
-- -- eqTest = refl _ _
-- Add the rest
-- unify (%pi _ E (%var 3 []) (%cl [(%var 6 []), (%var 3 []), (%var 0 []), (%var 2 []), (%var 1 []), (%var 0 [])] (Bnd 2))) with
-- (%pi _ E (%var 2 []) (%cl [(%var 6 []), (%var 2 []), (%var 0 []), (%var 1 []), (%var 0 [])] (Bnd 2)))
-- -> (%pi _ E (%var 3 []) (%cl [(%var 6 []), (%var 3 []), (%var 0 []), (%var 2 []), (%var 1 []), (%var 0 [])] (Bnd 2))) with
-- (%pi _ E (%var 2 []) (%cl [(%var 6 []), (%var 2 []), (%var 0 []), (%var 1 []), (%var 0 [])] (Bnd 2)))

View File

@@ -21,7 +21,7 @@ data PRen = PR Nat Nat (List Nat)
forceMeta : Val -> M Val forceMeta : Val -> M Val
-- TODO - need to look up metas -- TODO - need to look up metas
forceMeta (VMeta ix sp) = case !(lookupMeta ix) of forceMeta (VMeta ix sp) = case !(lookupMeta ix) of
(Unsolved k xs) => pure (VMeta ix sp) (Unsolved pos k xs) => pure (VMeta ix sp)
(Solved k t) => vappSpine t sp (Solved k t) => vappSpine t sp
forceMeta x = pure x forceMeta x = pure x
@@ -32,7 +32,7 @@ invert lvl sp = go sp []
go : SnocList Val -> List Nat -> M (List Nat) go : SnocList Val -> List Nat -> M (List Nat)
go [<] acc = pure $ reverse acc go [<] acc = pure $ reverse acc
go (xs :< VVar k [<]) acc = do go (xs :< VVar k [<]) acc = do
if elem k acc if elem k acc
then throwError $ E (0,0) "non-linear pattern" then throwError $ E (0,0) "non-linear pattern"
else go xs (k :: acc) else go xs (k :: acc)
go _ _ = throwError $ E (0,0) "non-variable in pattern" go _ _ = throwError $ E (0,0) "non-variable in pattern"
@@ -40,7 +40,7 @@ invert lvl sp = go sp []
-- we have to "lift" the renaming when we go under a lambda -- we have to "lift" the renaming when we go under a lambda
-- I think that essentially means our domain ix are one bigger, since we're looking at lvl -- I think that essentially means our domain ix are one bigger, since we're looking at lvl
-- in the codomain, so maybe we can just keep that value -- in the codomain, so maybe we can just keep that value
rename : Nat -> List Nat -> Nat -> Val -> M Tm rename : Nat -> List Nat -> Nat -> Val -> M Tm
rename meta ren lvl v = go ren lvl v rename meta ren lvl v = go ren lvl v
where where
go : List Nat -> Nat -> Val -> M Tm go : List Nat -> Nat -> Val -> M Tm
@@ -63,7 +63,7 @@ rename meta ren lvl v = go ren lvl v
lams : Nat -> Tm -> Tm lams : Nat -> Tm -> Tm
lams 0 tm = tm lams 0 tm = tm
lams (S k) tm = Lam "arg\{show k}" Explicit (lams k tm) lams (S k) tm = Lam "arg:\{show k}" Explicit (lams k tm)
solve : Nat -> Nat -> SnocList Val -> Val -> M () solve : Nat -> Nat -> SnocList Val -> Val -> M ()
solve l m sp t = do solve l m sp t = do
@@ -75,54 +75,89 @@ solve l m sp t = do
solveMeta top m soln solveMeta top m soln
pure () pure ()
unify : (l : Nat) -> Val -> Val -> M () parameters (ctx: Context)
unify : (l : Nat) -> Val -> Val -> M ()
unifySpine : Nat -> Bool -> SnocList Val -> SnocList Val -> M () unifySpine : Nat -> Bool -> SnocList Val -> SnocList Val -> M ()
unifySpine l False _ _ = throwError $ E (0,0) "unify failed" unifySpine l False _ _ = error [DS "unify failed at head"] -- unreachable now
unifySpine l True [<] [<] = pure () unifySpine l True [<] [<] = pure ()
unifySpine l True (xs :< x) (ys :< y) = unify l x y >> unifySpine l True xs ys unifySpine l True (xs :< x) (ys :< y) = unify l x y >> unifySpine l True xs ys
unifySpine l True _ _ = throwError $ E (0,0) "meta spine length mismatch" unifySpine l True _ _ = error [DS "meta spine length mismatch"]
unify l t u = do unify l t u = do
t' <- forceMeta t putStrLn "Unify \{show ctx.lvl}"
u' <- forceMeta u putStrLn " \{show l} \{show t}"
case (t',u') of putStrLn " =?= \{show u}"
(VLam _ _ t, VLam _ _ t' ) => unify (l + 1) !(t $$ VVar l [<]) !(t' $$ VVar l [<]) t' <- forceMeta t
(t, VLam _ _ t' ) => unify (l + 1) !(t `vapp` VVar l [<]) !(t' $$ VVar l [<]) u' <- forceMeta u
(VLam _ _ t, t' ) => unify (l + 1) !(t $$ VVar l [<]) !(t' `vapp` VVar l [<]) case (t',u') of
(VPi _ _ a b, VPi _ _ a' b') => unify l a a' >> unify (S l) !(b $$ VVar l [<]) !(b' $$ VVar l [<]) (VLam _ _ t, VLam _ _ t' ) => unify (l + 1) !(t $$ VVar l [<]) !(t' $$ VVar l [<])
(VVar k sp, VVar k' sp' ) => unifySpine l (k == k') sp sp' (t, VLam _ _ t' ) => unify (l + 1) !(t `vapp` VVar l [<]) !(t' $$ VVar l [<])
(VRef n sp, VRef n' sp' ) => unifySpine l (n == n') sp sp' (VLam _ _ t, t' ) => unify (l + 1) !(t $$ VVar l [<]) !(t' `vapp` VVar l [<])
(VMeta i sp, VMeta i' sp' ) => unifySpine l (i == i') sp sp' (VPi _ _ a b, VPi _ _ a' b') => unify l a a' >> unify (S l) !(b $$ VVar l [<]) !(b' $$ VVar l [<])
(VVar k sp, VVar k' sp' ) =>
(t, VMeta i' sp') => solve l i' sp' t if k == k' then unifySpine l (k == k') sp sp'
(VMeta i sp, t' ) => solve l i sp t' else error [DS "vvar mismatch \{show k} \{show k'}"]
(VU, VU) => pure () (VRef k sp, VRef k' sp' ) =>
_ => throwError $ E (0,0) "unify failed" if k == k' then unifySpine l (k == k') sp sp'
else error [DS "vref mismatch \{show k} \{show k'}"]
(VMeta k sp, VMeta k' sp' ) =>
if k == k' then unifySpine l (k == k') sp sp'
else solve l k sp (VMeta k' sp')
(t, VMeta i' sp') => solve l i' sp' t
(VMeta i sp, t' ) => solve l i sp t'
(VU, VU) => pure ()
-- REVIEW consider quoting back
_ => error [DS "unify failed", DS (show t'), DS "=?=", DS (show u') ]
insert : (ctx : Context) -> Tm -> Val -> M (Tm, Val)
insert ctx tm ty = do
case !(forceMeta ty) of
VPi x Implicit a b => do
m <- freshMeta ctx
mv <- eval ctx.env CBN m
insert ctx (App tm m) !(b $$ mv)
va => pure (tm, va)
export export
infer : Context -> Raw -> M (Tm, Val) infer : Context -> Raw -> M (Tm, Val)
export export
check : Context -> Raw -> Val -> M Tm check : Context -> Raw -> Val -> M Tm
check ctx (RSrcPos x tm) ty = check ({pos := x} ctx) tm ty check ctx tm ty with (force ty)
check ctx (RLam nm icit tm) ty = case ty of check ctx (RSrcPos x tm) _ | ty = check ({pos := x} ctx) tm ty
(VPi pinm icit a b) => do check ctx t@(RLam nm icit tm) _ | ty = case ty of
-- TODO icit (VPi nm' icit' a b) => do
let var = VVar (length ctx.env) [<] putStrLn "icits \{nm} \{show icit} \{nm'} \{show icit'}"
let ctx' = extend ctx nm a if icit == icit' then do
tm' <- check ctx' tm !(b $$ var) let var = VVar (length ctx.env) [<]
pure $ Lam nm icit tm' let ctx' = extend ctx nm a
other => error [(DS "Expected pi type, got \{show !(quote 0 ty)}")] tm' <- check ctx' tm !(b $$ var)
check ctx tm ty = do pure $ Lam nm icit tm'
(tm', ty') <- infer ctx tm else if icit' == Implicit then do
-- This is where the conversion check / pattern unification go let var = VVar (length ctx.env) [<]
unify ctx.lvl ty' ty ty' <- b $$ var
-- if quote 0 ty /= quote 0 ty' then sc <- check (extend ctx nm' a) t ty'
-- error [DS "type mismatch got", DD (quote 0 ty'), DS "expected", DD (quote 0 ty)] pure $ Lam nm' icit' sc
-- else pure tm' else
pure tm' error [(DS "Icity issue checking \{show t} at \{show ty}")]
other => error [(DS "Expected pi type, got \{show !(quote 0 ty)}")]
check ctx tm _ | (VPi nm' Implicit a b) = do
putStrLn "XXX edge \{show tm} against VPi"
let var = VVar (length ctx.env) [<]
ty' <- b $$ var
sc <- check (extend ctx nm' a) tm ty'
pure $ Lam nm' Implicit sc
check ctx tm _ | ty = do
-- We need to insert if it's not a Lam
-- TODO figure out why the exception is here (cribbed from kovacs)
(tm', ty') <- case !(infer ctx tm) of
(tm'@(Lam{}),ty') => pure (tm', ty')
(tm', ty') => insert ctx tm' ty'
putStrLn "infer \{show tm} to \{show tm'} : \{show ty'} expect \{show ty}"
when( ctx.lvl /= length ctx.env) $ error [DS "level mismatch \{show ctx.lvl} \{show ctx.env}"]
unify ctx ctx.lvl ty' ty
pure tm'
infer ctx (RVar nm) = go 0 ctx.types infer ctx (RVar nm) = go 0 ctx.types
where where
@@ -131,17 +166,36 @@ infer ctx (RVar nm) = go 0 ctx.types
Just (MkEntry name ty (Fn t)) => pure (Ref nm (Just t), !(eval [] CBN ty)) Just (MkEntry name ty (Fn t)) => pure (Ref nm (Just t), !(eval [] CBN ty))
Just (MkEntry name ty _) => pure (Ref nm Nothing, !(eval [] CBN ty)) Just (MkEntry name ty _) => pure (Ref nm Nothing, !(eval [] CBN ty))
Nothing => error [DS "\{show nm} not in scope"] Nothing => error [DS "\{show nm} not in scope"]
go i ((x, ty) :: xs) = if x == nm then pure $ (Bnd i, ty) go i ((x, ty) :: xs) = if x == nm then pure $ (Bnd i, ty)
else go (i + 1) xs else go (i + 1) xs
-- need environment of name -> type.. -- need environment of name -> type..
infer ctx (RApp t u icit) = do infer ctx (RApp t u icit) = do
-- icit will be used for insertion, lets get this working first... -- icit will be used for insertion, lets get this working first...
(t, tty) <- infer ctx t
case tty of (icit, t, tty) <- case the Icit icit of
(VPi str icit' a b) => do Explicit => do
u <- check ctx u a (t, tty) <- infer ctx t
pure (App t u, !(b $$ !(eval ctx.env CBN u))) (t, tty) <- insert ctx t tty
_ => error [DS "Expected Pi type"] pure (Explicit, t, tty)
Implicit => do
(t, tty) <- infer ctx t
pure (Implicit, t, tty)
(a,b) <- case !(forceMeta tty) of
(VPi str icit' a b) => if icit' == icit then pure (a,b)
else error [DS "IcitMismatch \{show icit} \{show icit'}"]
-- If it's not a VPi, try to unify it with a VPi
tty => do
putStrLn "unify PI for \{show tty}"
a <- eval ctx.env CBN !(freshMeta ctx)
b <- MkClosure ctx.env <$> freshMeta (extend ctx "x" ?hole)
unify ctx 0 tty (VPi "x" icit a b)
pure (a,b)
u <- check ctx u a
pure (App t u, !(b $$ !(eval ctx.env CBN u)))
infer ctx RU = pure (U, VU) -- YOLO infer ctx RU = pure (U, VU) -- YOLO
infer ctx (RPi nm icit ty ty2) = do infer ctx (RPi nm icit ty ty2) = do
ty' <- check ctx ty VU ty' <- check ctx ty VU
@@ -153,17 +207,24 @@ infer ctx (RLet str tm tm1 tm2) = error [DS "implement RLet"]
infer ctx (RSrcPos x tm) = infer ({pos := x} ctx) tm infer ctx (RSrcPos x tm) = infer ({pos := x} ctx) tm
infer ctx (RAnn tm rty) = do infer ctx (RAnn tm rty) = do
ty <- check ctx rty VU ty <- check ctx rty VU
vty <- eval ctx.env CBN ty vty <- eval ctx.env CBN ty
tm <- check ctx tm vty tm <- check ctx tm vty
pure (tm, vty) pure (tm, vty)
infer ctx (RLam str icit tm) = error [DS "can't infer lambda"] infer ctx (RLam nm icit tm) = do
a <- freshMeta ctx >>= eval ctx.env CBN
let ctx' = extend ctx nm a
(tm', b) <- infer ctx' tm
putStrLn "make lam for \{show nm} scope \{show tm'} : \{show b}"
pure $ (Lam nm icit tm', VPi nm icit a $ MkClosure ctx.env !(quote (S ctx.lvl) b))
-- error {ctx} [DS "can't infer lambda"]
infer ctx RHole = do infer ctx RHole = do
ty <- freshMeta ctx ty <- freshMeta ctx
vty <- eval ctx.env CBN ty vty <- eval ctx.env CBN ty
tm <- freshMeta ctx tm <- freshMeta ctx
pure (tm, vty) pure (tm, vty)
infer ctx tm = error [DS "Implement infer \{show tm}"] infer ctx tm = error [DS "Implement infer \{show tm}"]
-- I don't have types for these yet... -- I don't have types for these yet...

View File

@@ -14,6 +14,7 @@ import Lib.Token
import Lib.Parser.Impl import Lib.Parser.Impl
import Syntax import Syntax
import Data.List import Data.List
import Data.Maybe
-- There is the whole core vs surface thing here. -- There is the whole core vs surface thing here.
-- might be best to do core first/ Technically don't -- might be best to do core first/ Technically don't
@@ -186,10 +187,11 @@ ibind : Parser (List (String, Icit, Raw))
ibind = do ibind = do
sym "{" sym "{"
names <- some ident names <- some ident
sym ":" ty <- optional (sym ":" >> typeExpr)
ty <- typeExpr pos <- getPos
sym "}" sym "}"
pure $ map (\name => (name, Explicit, ty)) names -- getPos is a hack here, I would like to position at the name...
pure $ map (\name => (name, Implicit, fromMaybe (RSrcPos pos RHole) ty)) names
-- Collect a bunch of binders (A : U) {y : A} -> ... -- Collect a bunch of binders (A : U) {y : A} -> ...
binders : Parser Raw binders : Parser Raw

View File

@@ -14,7 +14,7 @@ SourcePos : Type
SourcePos = (Int,Int) SourcePos = (Int,Int)
emptyPos : SourcePos emptyPos : SourcePos
emptyPos = (0,0) emptyPos = (0,0)
-- Error of a parse -- Error of a parse
public export public export
@@ -27,17 +27,17 @@ showError src (E (line, col) msg) = "ERROR at \{show (line,col)}: \{msg}\n" ++ g
where where
go : Int -> List String -> String go : Int -> List String -> String
go l [] = "" go l [] = ""
go l (x :: xs) = go l (x :: xs) =
if l == line then if l == line then
" \{x}\n \{replicate (cast col) ' '}^\n" " \{x}\n \{replicate (cast col) ' '}^\n"
else if line - 3 < l then " " ++ x ++ "\n" ++ go (l + 1) xs else if line - 3 < l then " " ++ x ++ "\n" ++ go (l + 1) xs
else go (l + 1) xs else go (l + 1) xs
-- Result of a parse -- Result of a parse
public export public export
data Result : Type -> Type where data Result : Type -> Type where
OK : a -> (toks : TokenList) -> (com : Bool) -> Result a OK : a -> (toks : TokenList) -> (com : Bool) -> Result a
Fail : Bool -> Error -> (toks : TokenList) -> (com : Bool) -> Result a Fail : Bool -> Error -> (toks : TokenList) -> (com : Bool) -> Result a
export export
Functor Result where Functor Result where
@@ -92,13 +92,13 @@ Functor Parser where
map f (P pa) = P $ \ toks, com, col => map f (pa toks com col) map f (P pa) = P $ \ toks, com, col => map f (pa toks com col)
export export
Applicative Parser where Applicative Parser where
pure pa = P (\ toks, com, col => OK pa toks com) pure pa = P (\ toks, com, col => OK pa toks com)
P pab <*> P pa = P $ \toks,com,col => P pab <*> P pa = P $ \toks,com,col =>
case pab toks com col of case pab toks com col of
Fail fatal err toks com => Fail fatal err toks com Fail fatal err toks com => Fail fatal err toks com
OK f toks com => OK f toks com =>
case pa toks com col of case pa toks com col of
(OK x toks com) => OK (f x) toks com (OK x toks com) => OK (f x) toks com
(Fail fatal err toks com) => Fail fatal err toks com (Fail fatal err toks com) => Fail fatal err toks com
@@ -125,7 +125,7 @@ pred : (BTok -> Bool) -> String -> Parser String
pred f msg = P $ \toks,com,col => pred f msg = P $ \toks,com,col =>
case toks of case toks of
(t :: ts) => if f t then OK (value t) ts com else Fail False (error toks "\{msg} vt:\{value t}") toks com (t :: ts) => if f t then OK (value t) ts com else Fail False (error toks "\{msg} vt:\{value t}") toks com
[] => Fail False (error toks "eof") toks com [] => Fail False (error toks "\{msg} at EOF") toks com
export export
commit : Parser () commit : Parser ()
@@ -138,7 +138,7 @@ defer f = P $ \toks,com,col => runP (f ()) toks com col
mutual mutual
export some : Parser a -> Parser (List a) export some : Parser a -> Parser (List a)
some p = defer $ \_ => [| p :: many p|] --(::) <$> p <*> many p) some p = defer $ \_ => [| p :: many p|] --(::) <$> p <*> many p)
export many : Parser a -> Parser (List a) export many : Parser a -> Parser (List a)
many p = some p <|> pure [] many p = some p <|> pure []
@@ -169,8 +169,8 @@ export
sameLevel : Parser a -> Parser a sameLevel : Parser a -> Parser a
sameLevel (P p) = P $ \toks,com,(l,c) => case toks of sameLevel (P p) = P $ \toks,com,(l,c) => case toks of
[] => p toks com (l,c) [] => p toks com (l,c)
(t :: _) => (t :: _) =>
let (tl,tc) = start t let (tl,tc) = start t
in if tc == c then p toks com (tl, c) in if tc == c then p toks com (tl, c)
else if c < tc then Fail False (error toks "unexpected indent") toks com else if c < tc then Fail False (error toks "unexpected indent") toks com
else Fail False (error toks "unexpected indent") toks com else Fail False (error toks "unexpected indent") toks com

View File

@@ -13,6 +13,7 @@ export
data Doc = Empty | Line | Text String | Nest Nat Doc | Seq Doc Doc | Alt Doc Doc data Doc = Empty | Line | Text String | Nest Nat Doc | Seq Doc Doc | Alt Doc Doc
||| `DOC` is an intermediate form used during layout/rendering ||| `DOC` is an intermediate form used during layout/rendering
||| The capitalization is the opposite of the paper.
data DOC = EMPTY | TEXT String DOC | LINE Nat DOC data DOC = EMPTY | TEXT String DOC | LINE Nat DOC
flatten : Doc -> Doc flatten : Doc -> Doc

View File

@@ -3,6 +3,9 @@
-- maybe watch https://www.youtube.com/watch?v=3gef0_NFz8Q -- maybe watch https://www.youtube.com/watch?v=3gef0_NFz8Q
-- or drop the indices for now. -- or drop the indices for now.
-- ***
-- Kovacs has icity on App, and passes it around, but I'm not sure where it is needed since the insertion happens based on Raw.
module Lib.TT module Lib.TT
-- For SourcePos -- For SourcePos
import Lib.Parser.Impl import Lib.Parser.Impl
@@ -34,17 +37,21 @@ export
error' : String -> M a error' : String -> M a
error' msg = throwError $ E (0,0) msg error' msg = throwError $ E (0,0) msg
-- order does indeed matter on the meta arguments
-- because of dependent types (if we want something well-typed back out)
export export
freshMeta : Context -> M Tm freshMeta : Context -> M Tm
freshMeta ctx = do freshMeta ctx = do
mc <- readIORef ctx.metas mc <- readIORef ctx.metas
writeIORef ctx.metas $ { next $= S, metas $= (Unsolved mc.next ctx.bds ::) } mc putStrLn "INFO at \{show ctx.pos}: fresh meta \{show mc.next}"
pure $ applyBDs 0 (Meta mc.next) ctx.bds writeIORef ctx.metas $ { next $= S, metas $= (Unsolved ctx.pos mc.next ctx.bds ::) } mc
pure $ applyBDs 0 (Meta mc.next) ctx.bds
where where
-- hope I got the right order here :) -- hope I got the right order here :)
applyBDs : Nat -> Tm -> List BD -> Tm applyBDs : Nat -> Tm -> List BD -> Tm
applyBDs k t [] = t applyBDs k t [] = t
-- review the order here
applyBDs k t (Bound :: xs) = App (applyBDs (S k) t xs) (Bnd k) applyBDs k t (Bound :: xs) = App (applyBDs (S k) t xs) (Bnd k)
applyBDs k t (Defined :: xs) = applyBDs (S k) t xs applyBDs k t (Defined :: xs) = applyBDs (S k) t xs
@@ -57,7 +64,7 @@ lookupMeta ix = do
where where
go : List MetaEntry -> M MetaEntry go : List MetaEntry -> M MetaEntry
go [] = error' "Meta \{show ix} not found" go [] = error' "Meta \{show ix} not found"
go (meta@(Unsolved k ys) :: xs) = if k == ix then pure meta else go xs go (meta@(Unsolved _ k ys) :: xs) = if k == ix then pure meta else go xs
go (meta@(Solved k x) :: xs) = if k == ix then pure meta else go xs go (meta@(Solved k x) :: xs) = if k == ix then pure meta else go xs
export export
@@ -69,10 +76,12 @@ solveMeta ctx ix tm = do
where where
go : List MetaEntry -> SnocList MetaEntry -> M (List MetaEntry) go : List MetaEntry -> SnocList MetaEntry -> M (List MetaEntry)
go [] _ = error' "Meta \{show ix} not found" go [] _ = error' "Meta \{show ix} not found"
go (meta@(Unsolved k _) :: xs) lhs = if k == ix go (meta@(Unsolved pos k _) :: xs) lhs = if k == ix
then pure $ lhs <>> (Solved k tm :: xs) then do
putStrLn "INFO at \{show pos}: solve \{show k} as \{show tm}"
pure $ lhs <>> (Solved k tm :: xs)
else go xs (lhs :< meta) else go xs (lhs :< meta)
go (meta@(Solved k _) :: xs) lhs = if k == ix go (meta@(Solved k _) :: xs) lhs = if k == ix
then error' "Meta \{show ix} already solved!" then error' "Meta \{show ix} already solved!"
else go xs (lhs :< meta) else go xs (lhs :< meta)
@@ -88,7 +97,7 @@ export
extend : Context -> String -> Val -> Context extend : Context -> String -> Val -> Context
extend ctx name ty = extend ctx name ty =
{ lvl $= S, env $= (VVar ctx.lvl [<] ::), types $= ((name, ty) ::), bds $= (Bound ::) } ctx { lvl $= S, env $= (VVar ctx.lvl [<] ::), types $= ((name, ty) ::), bds $= (Bound ::) } ctx
-- I guess we define things as values? -- I guess we define things as values?
export export
define : Context -> String -> Val -> Val -> Context define : Context -> String -> Val -> Val -> Context
@@ -146,7 +155,7 @@ eval env mode (App t u) = vapp !(eval env mode t) !(eval env mode u)
eval env mode U = pure VU eval env mode U = pure VU
eval env mode (Meta i) = eval env mode (Meta i) =
case !(lookupMeta i) of case !(lookupMeta i) of
(Unsolved k xs) => pure $ VMeta i [<] (Unsolved _ k xs) => pure $ VMeta i [<]
(Solved k t) => pure $ t (Solved k t) => pure $ t
eval env mode (Lam x icit t) = pure $ VLam x icit (MkClosure env t) eval env mode (Lam x icit t) = pure $ VLam x icit (MkClosure env t)
eval env mode (Pi x icit a b) = pure $ VPi x icit !(eval env mode a) (MkClosure env b) eval env mode (Pi x icit a b) = pure $ VPi x icit !(eval env mode a) (MkClosure env b)
@@ -154,13 +163,13 @@ eval env mode (Let x icit ty t u) = eval (!(eval env mode t) :: env) mode u
eval env mode (Bnd i) = case getAt i env of eval env mode (Bnd i) = case getAt i env of
Just rval => pure rval Just rval => pure rval
Nothing => error' "Bad deBruin index \{show i}" Nothing => error' "Bad deBruin index \{show i}"
export export
quote : (lvl : Nat) -> Val -> M Tm quote : (lvl : Nat) -> Val -> M Tm
quoteSp : (lvl : Nat) -> Tm -> SnocList Val -> M Tm quoteSp : (lvl : Nat) -> Tm -> SnocList Val -> M Tm
quoteSp lvl t [<] = pure t quoteSp lvl t [<] = pure t
quoteSp lvl t (xs :< x) = quoteSp lvl t (xs :< x) =
pure $ App !(quoteSp lvl t xs) !(quote lvl x) pure $ App !(quoteSp lvl t xs) !(quote lvl x)
-- quoteSp lvl (App t !(quote lvl x)) xs -- snoc says previous is right -- quoteSp lvl (App t !(quote lvl x)) xs -- snoc says previous is right

View File

@@ -28,6 +28,11 @@ data Icit = Implicit | Explicit
%name Icit icit %name Icit icit
export
Show Icit where
show Implicit = "Implicit"
show Explicit = "Explicit"
public export public export
data BD = Bound | Defined data BD = Bound | Defined
@@ -41,6 +46,7 @@ data Tm : Type where
-- kovacs optimization, I think we can App out meta instead -- kovacs optimization, I think we can App out meta instead
-- InsMeta : Nat -> List BD -> Tm -- InsMeta : Nat -> List BD -> Tm
Lam : Name -> Icit -> Tm -> Tm Lam : Name -> Icit -> Tm -> Tm
-- Do we need to remember Icit here?
App : Tm -> Tm -> Tm App : Tm -> Tm -> Tm
U : Tm U : Tm
Pi : Name -> Icit -> Tm -> Tm -> Tm Pi : Name -> Icit -> Tm -> Tm -> Tm
@@ -57,13 +63,14 @@ Show Tm where
show (App t u) = "(\{show t} \{show u})" show (App t u) = "(\{show t} \{show u})"
show (Meta i) = "(Meta \{show i})" show (Meta i) = "(Meta \{show i})"
show U = "U" show U = "U"
show (Pi str icit t u) = "( \{str} : \{show t} => \{show u})" show (Pi str Implicit t u) = "(Pi (\{str} : \{show t}) => \{show u})"
show (Pi str Explicit t u) = "(Pi {\{str} : \{show t}} => \{show u})"
show (Let str icit t u v) = "let \{str} : \{show t} = \{show u} in \{show v}" show (Let str icit t u v) = "let \{str} : \{show t} = \{show u} in \{show v}"
-- I can't really show val because it's HOAS... -- I can't really show val because it's HOAS...
-- TODO derive -- TODO derive
export export
Eq Icit where Eq Icit where
Implicit == Implicit = True Implicit == Implicit = True
Explicit == Explicit = True Explicit == Explicit = True
@@ -126,9 +133,6 @@ data Val : Type where
VPi : Name -> Icit -> Lazy Val -> Closure -> Val VPi : Name -> Icit -> Lazy Val -> Closure -> Val
VU : Val VU : Val
Show Icit where
show Implicit = "I"
show Explicit = "E"
Show Closure Show Closure
@@ -138,7 +142,8 @@ Show Val where
show (VRef nm sp) = "(%ref \{nm} \{show sp})" show (VRef nm sp) = "(%ref \{nm} \{show sp})"
show (VMeta ix sp) = "(%meta \{show ix} \{show sp})" show (VMeta ix sp) = "(%meta \{show ix} \{show sp})"
show (VLam str icit x) = "(%lam \{str} \{show icit} \{show x})" show (VLam str icit x) = "(%lam \{str} \{show icit} \{show x})"
show (VPi str icit x y) = "(%pi \{str} \{show icit} \{show x} \{show y})" show (VPi str Implicit x y) = "(%pi {\{str} : \{show x}}. \{show y})"
show (VPi str Explicit x y) = "(%pi (\{str} : \{show x}). \{show y})"
show VU = "U" show VU = "U"
public export public export
@@ -174,7 +179,7 @@ So I guess we have top and local then?
With haskell syntax. I think we can have Axiom for claims and rewrite to def later. With haskell syntax. I think we can have Axiom for claims and rewrite to def later.
Hmm, so given ezoo, if I'm going simple, I could keep BDs short, and use the normal Hmm, so given ezoo, if I'm going simple, I could keep BDs short, and use the normal
context. (Zoo4.lean:222) I'd probably still need an undefined/axiom marker as a value? context. (Zoo4.lean:222) I'd probably still need an undefined/axiom marker as a value?
ok, so with just one context, Env is List Val and we're getting Tm back from type checking. ok, so with just one context, Env is List Val and we're getting Tm back from type checking.
@@ -182,9 +187,14 @@ Can I get val back? Do we need to quote? What happens if we don't?
-} -}
-- FIXME remove List BD
public export public export
data MetaEntry = Unsolved Nat (List BD) | Solved Nat Val data MetaEntry = Unsolved SourcePos Nat (List BD) | Solved Nat Val
export
covering
Show MetaEntry where
show (Unsolved pos k xs) = "Unsolved \{show pos} \{show k}"
show (Solved k x) = "Solved \{show k} \{show x}"
public export public export
record MetaContext where record MetaContext where
@@ -241,7 +251,7 @@ record Context where
-- so we'll try "bds" determines length of local context -- so we'll try "bds" determines length of local context
bds : List BD -- bound or defined bds : List BD -- bound or defined
pos : SourcePos -- the last SourcePos that we saw pos : SourcePos -- the last SourcePos that we saw
-- We only need this here if we don't pass TopContext -- We only need this here if we don't pass TopContext
-- top : TopContext -- top : TopContext
metas : IORef MetaContext metas : IORef MetaContext

View File

@@ -48,6 +48,7 @@ dumpContext top = do
processDecl : Decl -> M () processDecl : Decl -> M ()
processDecl (TypeSig nm tm) = do processDecl (TypeSig nm tm) = do
top <- get top <- get
putStrLn "-----"
putStrLn "TypeSig \{nm} \{show tm}" putStrLn "TypeSig \{nm} \{show tm}"
ty <- check (mkCtx top.metas) tm VU ty <- check (mkCtx top.metas) tm VU
putStrLn "got \{show ty}" putStrLn "got \{show ty}"
@@ -55,6 +56,7 @@ processDecl (TypeSig nm tm) = do
-- FIXME - this should be in another file -- FIXME - this should be in another file
processDecl (Def nm raw) = do processDecl (Def nm raw) = do
putStrLn "-----"
putStrLn "def \{show nm}" putStrLn "def \{show nm}"
ctx <- get ctx <- get
let pos = case raw of let pos = case raw of
@@ -67,12 +69,13 @@ processDecl (Def nm raw) = do
| _ => throwError $ E pos "\{nm} already defined" | _ => throwError $ E pos "\{nm} already defined"
putStrLn "check \{nm} = \{show raw} at \{show $ ty}" putStrLn "check \{nm} = \{show raw} at \{show $ ty}"
vty <- eval empty CBN ty vty <- eval empty CBN ty
putStrLn "vty is \{show vty}"
tm <- check (mkCtx ctx.metas) raw vty tm <- check (mkCtx ctx.metas) raw vty
putStrLn "Ok \{show tm}" putStrLn "Ok \{show tm}"
put (addDef ctx nm tm ty) put (addDef ctx nm tm ty)
processDecl (DCheck tm ty) = do processDecl (DCheck tm ty) = do
top <- get top <- get
putStrLn "check \{show tm} at \{show ty}" putStrLn "check \{show tm} at \{show ty}"
ty' <- check (mkCtx top.metas) tm VU ty' <- check (mkCtx top.metas) tm VU
@@ -84,7 +87,7 @@ processDecl (DCheck tm ty) = do
putStrLn "norm \{show norm}" putStrLn "norm \{show norm}"
-- top <- get -- top <- get
-- ctx <- mkCtx top.metas -- ctx <- mkCtx top.metas
-- I need a type to check against -- I need a type to check against
-- norm <- nf [] x -- norm <- nf [] x
putStrLn "NF " putStrLn "NF "
@@ -108,7 +111,7 @@ processDecl (Data nm ty cons) = do
dty <- check (mkCtx ctx.metas) tm VU dty <- check (mkCtx ctx.metas) tm VU
modify $ claim nm' dty modify $ claim nm' dty
_ => throwError $ E (0,0) "expected TypeSig" _ => throwError $ E (0,0) "expected TypeSig"
pure () pure ()
where where
checkDeclType : Tm -> M () checkDeclType : Tm -> M ()
@@ -128,9 +131,9 @@ processFile fn = do
printLn "process Decls" printLn "process Decls"
Right _ <- tryError $ traverse_ processDecl res.decls Right _ <- tryError $ traverse_ processDecl res.decls
| Left y => putStrLn (showError src y) | Left y => putStrLn (showError src y)
dumpContext !get dumpContext !get
main' : M () main' : M ()
main' = do main' = do
args <- getArgs args <- getArgs
@@ -139,7 +142,7 @@ main' = do
| _ => putStrLn "Usage: newt foo.newt" | _ => putStrLn "Usage: newt foo.newt"
-- Right files <- listDir "eg" -- Right files <- listDir "eg"
-- | Left err => printLn err -- | Left err => printLn err
traverse_ processFile (filter (".newt" `isSuffixOf`) files) traverse_ processFile (filter (".newt" `isSuffixOf`) files)
main : IO () main : IO ()

View File

@@ -114,11 +114,6 @@ Show Pattern where
Show CaseAlt where Show CaseAlt where
show (MkAlt x y)= foo ["MkAlt", show x, assert_total $ show y] show (MkAlt x y)= foo ["MkAlt", show x, assert_total $ show y]
Show Icit where
show Implicit = "Implicit"
show Explicit = "Explicit"
-- show Eq = "Eq"
covering covering
Show Raw where Show Raw where
show RHole = "_" show RHole = "_"