dunham/newt
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Add more stuff to equality and more logging

Browse Source 
Need to get names in there though.
This commit is contained in:
Steve Dunham
2024-07-16 22:07:37 -07:00
parent c0f9262c9a
commit 3d477be52b
6 changed files with 120 additions and 88 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
README.md
View File

@@ -1,4 +1,6 @@
- [ ] Add PRINTME / ?
Parser is in place.
Ditched well-scoped for now.
@@ -36,10 +38,13 @@ When I self host, I'll have to drop or implement typeclasses. I do understand au
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?
- [ ] Erased values?
- pi-forall handles this, so it's probably not too crazy. She won't go near implicits and I think I understand why.
- I don't think I Want to go full QTT at the moment
- Is erased different from 0/many?
Parser:
- [x] parser for block comments

23
newt/eq.newt
View File

@@ -1,22 +1,29 @@
module Equality
-- we don't have implicits yet, so this won't typecheck
-- Leibniz equality
Eq : {A : U} -> A -> A -> U
Eq = \ {A} => \ x => \ y => (P : A -> U) -> P x -> P y
Eq = \ {A} x y => (P : A -> U) -> P x -> P y
refl : {A : U} {x : A} -> Eq x x
refl = \ P Px => Px
trans : {A : U} {x y z : A} -> Eq x y -> Eq y z -> Eq x z
trans = \ Exy Eyz => Eyz (\ w => Eq x w) Exy
sym : {A : U} {x y : A} -> Eq x y -> Eq y x
sym = \ Exy => Exy (\ z => Eq z x) refl
id : {A} -> A -> A
id = \ x => x
coerce : {A B : U} -> Eq A B -> A -> B
-- coerce refl a = a
coerce = \ EqAB a => EqAB id a
-- can I write J without pattern matching?
-- J : {A : U} {x y : A} (eq : Eq x y) ->
-- (mot : (x : A) (P : Eq x y) -> U)
-- (b : mot y refl) ->
-- mot x eq
-- J : {A : U} ->
-- {C : (x y : A) -> Eq x y -> U} ->
-- (c : (x : _) -> C x x refl) ->
-- (x y : A) ->
-- (p : Eq x y) ->
-- C x y p
-- J = \ c x y eq => eq (\ z => C x z _) (c x)

110
src/Lib/Check.idr
View File

@@ -24,57 +24,58 @@ forceMeta (VMeta ix sp) = case !(lookupMeta ix) of
(Solved k t) => vappSpine t sp
forceMeta x = pure x
-- return renaming, the position is the new VVar
invert : Nat -> SnocList Val -> M (List Nat)
invert lvl sp = go sp []
where
go : SnocList Val -> List Nat -> M (List Nat)
go [<] acc = pure $ reverse acc
go (xs :< VVar k [<]) acc = do
if elem k acc
then throwError $ E (0,0) "non-linear pattern"
else go xs (k :: acc)
go _ _ = throwError $ E (0,0) "non-variable in pattern"
-- 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
-- in the codomain, so maybe we can just keep that value
rename : Nat -> List Nat -> Nat -> Val -> M Tm
rename meta ren lvl v = go ren lvl v
where
go : List Nat -> Nat -> Val -> M Tm
goSpine : List Nat -> Nat -> Tm -> SnocList Val -> M Tm
goSpine ren lvl tm [<] = pure tm
goSpine ren lvl tm (xs :< x) = do
xtm <- go ren lvl x
goSpine ren lvl (App tm xtm) xs
go ren lvl (VVar k sp) = case findIndex (== k) ren of
Nothing => throwError $ E (0,0) "scope/skolem thinger"
Just x => goSpine ren lvl (Bnd $ cast x) sp
go ren lvl (VRef nm sp) = goSpine ren lvl (Ref nm Nothing) sp
go ren lvl (VMeta ix sp) = if ix == meta
then throwError $ E (0,0) "meta occurs check"
else goSpine ren lvl (Meta ix) sp
go ren lvl (VLam n t) = pure (Lam n !(go (lvl :: ren) (S lvl) !(t $$ VVar lvl [<])))
go ren lvl (VPi n icit ty tm) = pure (Pi n icit !(go ren lvl ty) !(go (lvl :: ren) (S lvl) !(tm $$ VVar lvl [<])))
go ren lvl VU = pure U
lams : Nat -> Tm -> Tm
lams 0 tm = tm
lams (S k) tm = Lam "arg:\{show k}" (lams k tm)
solve : Nat -> Nat -> SnocList Val -> Val -> M ()
solve l m sp t = do
ren <- invert l sp
tm <- rename m ren l t
let tm = lams (length sp) tm
top <- get
soln <- eval [] CBN tm
solveMeta top m soln
pure ()
parameters (ctx: Context)
-- return renaming, the position is the new VVar
invert : Nat -> SnocList Val -> M (List Nat)
invert lvl sp = go sp []
where
go : SnocList Val -> List Nat -> M (List Nat)
go [<] acc = pure $ reverse acc
go (xs :< VVar k [<]) acc = do
if elem k acc
then error [DS "non-linear pattern"]
else go xs (k :: acc)
go _ _ = error [DS "non-variable in pattern"]
-- 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
-- in the codomain, so maybe we can just keep that value
rename : Nat -> List Nat -> Nat -> Val -> M Tm
rename meta ren lvl v = go ren lvl v
where
go : List Nat -> Nat -> Val -> M Tm
goSpine : List Nat -> Nat -> Tm -> SnocList Val -> M Tm
goSpine ren lvl tm [<] = pure tm
goSpine ren lvl tm (xs :< x) = do
xtm <- go ren lvl x
goSpine ren lvl (App tm xtm) xs
go ren lvl (VVar k sp) = case findIndex (== k) ren of
Nothing => error [DS "scope/skolem thinger"]
Just x => goSpine ren lvl (Bnd $ cast x) sp
go ren lvl (VRef nm sp) = goSpine ren lvl (Ref nm Nothing) sp
go ren lvl (VMeta ix sp) = if ix == meta
then error [DS "meta occurs check"]
else goSpine ren lvl (Meta ix) sp
go ren lvl (VLam n t) = pure (Lam n !(go (lvl :: ren) (S lvl) !(t $$ VVar lvl [<])))
go ren lvl (VPi n icit ty tm) = pure (Pi n icit !(go ren lvl ty) !(go (lvl :: ren) (S lvl) !(tm $$ VVar lvl [<])))
go ren lvl VU = pure U
lams : Nat -> Tm -> Tm
lams 0 tm = tm
lams (S k) tm = Lam "arg:\{show k}" (lams k tm)
solve : Nat -> Nat -> SnocList Val -> Val -> M ()
solve l m sp t = do
ren <- invert l sp
tm <- rename m ren l t
let tm = lams (length sp) tm
top <- get
soln <- eval [] CBN tm
solveMeta top m soln
pure ()
unify : (l : Nat) -> Val -> Val -> M ()
unifySpine : Nat -> Bool -> SnocList Val -> SnocList Val -> M ()
@@ -147,6 +148,10 @@ check ctx tm ty with (force ty)
ty' <- b $$ var
sc <- check (extend ctx nm' a) tm ty'
pure $ Lam nm' sc
-- TODO Work in progress
-- I'd like to continue and also this is useless without some var names
check ctx RHole _ | ty = do
error [DS "hole has type \{show ty}"]
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)
@@ -158,6 +163,7 @@ check ctx tm ty with (force ty)
unify ctx ctx.lvl ty' ty
pure tm'
infer ctx (RVar nm) = go 0 ctx.types
where
go : Nat -> Vect n (String, Val) -> M (Tm, Val)
@@ -218,7 +224,7 @@ infer ctx (RLam nm icit tm) = do
pure $ (Lam nm 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 RImplicit = do
ty <- freshMeta ctx
vty <- eval ctx.env CBN ty
tm <- freshMeta ctx
@@ -231,6 +237,6 @@ infer ctx tm = error [DS "Implement infer \{show tm}"]
-- infer ctx (RLit (LInt i)) = ?rhs_11
-- infer ctx (RLit (LBool x)) = ?rhs_12
-- infer ctx (RCase tm xs) = ?rhs_9
-- infer ctx RHole = ?todo_meta2
-- infer ctx RImplicit = ?todo_meta2
-- The idea here is to insert a hole for a parse error
-- infer ctx (RParseError str) = ?todo_insert_meta

20
src/Lib/Parser.idr
View File

@@ -65,7 +65,8 @@ atom : Parser Raw
atom = withPos (RU <$ keyword "U"
<|> RVar <$> ident
<|> lit
<|> RHole <$ keyword "_")
<|> RImplicit <$ keyword "_"
<|> RHole <$ keyword "?")
<|> parens typeExpr
-- Argument to a Spine
@@ -116,7 +117,7 @@ letExpr = do
keyword' "in"
scope <- typeExpr
pure $ foldl (\ acc, (n,v) => RLet n RHole v acc) scope alts
pure $ foldl (\ acc, (n,v) => RLet n RImplicit v acc) scope alts
where
letAssign : Parser (Name,Raw)
letAssign = do
@@ -186,18 +187,20 @@ ebind = do
ibind : Parser (List (String, Icit, Raw))
ibind = do
sym "{"
names <- some ident
ty <- optional (sym ":" >> typeExpr)
pos <- getPos
sym "}"
-- getPos is a hack here, I would like to position at the name...
pure $ map (\name => (name, Implicit, fromMaybe (RSrcPos pos RHole) ty)) names
mustWork $ do
names <- some ident
ty <- optional (sym ":" >> typeExpr)
pos <- getPos
sym "}"
-- getPos is a hack here, I would like to position at the name...
pure $ map (\name => (name, Implicit, fromMaybe (RSrcPos pos RImplicit) ty)) names
-- Collect a bunch of binders (A : U) {y : A} -> ...
binders : Parser Raw
binders = do
binds <- many (ibind <|> ebind)
sym "->"
commit
scope <- typeExpr
pure $ foldr mkBind scope (join binds)
where
@@ -274,4 +277,3 @@ data ReplCmd =
export parseRepl : Parser ReplCmd
parseRepl = Def <$> parseDecl <|> Norm <$ keyword "#nf" <*> typeExpr
<|> Check <$ keyword "#check" <*> typeExpr

10
src/Main.idr
View File

@@ -7,6 +7,7 @@ import Control.Monad.State
import Data.List
import Data.String
import Data.Vect
import Data.IORef
import Lib.Check
import Lib.Parser
import Lib.Parser.Impl
@@ -31,7 +32,6 @@ App, but we have a way to make that work on javascript.
I still want to stay in MonadError outside this file though.
-}
@@ -73,6 +73,14 @@ processDecl (Def nm raw) = do
putStrLn "vty is \{show vty}"
tm <- check (mkCtx ctx.metas) raw vty
putStrLn "Ok \{show tm}"
mc <- readIORef ctx.metas
for_ mc.metas $ \case
(Solved k x) => pure ()
(Unsolved (l,c) k xs) => do
-- putStrLn "ERROR at (\{show l}, \{show c}): Unsolved meta \{show k}"
throwError $ E (l,c) "Unsolved meta \{show k}"
put (addDef ctx nm tm ty)
processDecl (DCheck tm ty) = do

8
src/Syntax.idr
View File

@@ -39,7 +39,9 @@ data Raw : Type where
RAnn : (tm : Raw) -> (ty : Raw) -> Raw
RLit : Literal -> Raw
RCase : (scrut : Raw) -> (alts : List CaseAlt) -> Raw
RImplicit : Raw
RHole : Raw
-- not used, but intended to allow error recovery
RParseError : String -> Raw
%name Raw tm
@@ -116,7 +118,8 @@ Show CaseAlt where
covering
Show Raw where
show RHole = "_"
show RImplicit = "_"
show RHole = "?"
show (RVar name) = foo ["RVar", show name]
show (RAnn t ty) = foo [ "RAnn", show t, show ty]
show (RLit x) = foo [ "RLit", show x]
@@ -164,7 +167,8 @@ Pretty Raw where
asDoc p (RLit (LInt i)) = text $ show i
asDoc p (RLit (LBool x)) = text $ show x
asDoc p (RCase x xs) = text "TODO - RCase"
asDoc p RHole = text "_"
asDoc p RImplicit = text "_"
asDoc p RHole = text "?"
asDoc p (RParseError str) = text "ParseError \{str}"
export