Add more stuff to equality and more logging

Need to get names in there though.
2024-07-16 22:07:37 -07:00
parent c0f9262c9a
commit 3d477be52b
6 changed files with 120 additions and 88 deletions
--- a/src/Lib/Check.idr
+++ b/src/Lib/Check.idr
@@ -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
--- a/src/Lib/Parser.idr
+++ b/src/Lib/Parser.idr
@@ -4,7 +4,7 @@ import Lib.Types
 -- The SourcePos stuff is awkward later on. We might want bounds on productions
 -- But we might want to consider something more generic and closer to lean?

-- app: foo {a} a b 
+-- app: foo {a} a b
 -- lam: λ {A} {b : A} (c : Blah) d e f => something
 -- lam: \ {A} {b : A} (c : Blah) d e f => something
 -- pi: (A : Set) -> {b : A} -> (c : Foo b) -> c -> bar d
@@ -25,7 +25,7 @@ import Data.Maybe
 -- so holes and all that

 -- After the parser runs, see below, take a break and finish pi-forall
-- exercises.  There is some fill in the parser stuff that may show 
+-- exercises.  There is some fill in the parser stuff that may show
 -- the future.

 ident = token Ident
@@ -53,7 +53,7 @@ lit = do
  t <- token Number
  pure $ RLit (LInt (cast t))

-- typeExpr is term with arrows. 
+-- typeExpr is term with arrows.
 export typeExpr : Parser Raw
 export term : (Parser Raw)

@@ -63,9 +63,10 @@ withPos p = RSrcPos <$> getPos <*> p
 -- the inside of Raw
 atom : Parser Raw
 atom = withPos (RU <$ keyword "U"
-              <|> RVar <$> ident 
+              <|> RVar <$> ident
              <|> lit
-              <|> RHole <$ keyword "_")
+              <|> RImplicit <$ keyword "_"
+              <|> RHole <$ keyword "?")
    <|> parens typeExpr

 -- Argument to a Spine
@@ -91,12 +92,12 @@ parseApp = do
  hd <- atom
  rest <- many pArg
  pure $ foldl (\a, (c,b) => RApp a b c) hd rest
-  
+
 parseOp : Parser Raw
 parseOp = parseApp >>= go 0
  where
    go : Int -> Raw -> Parser Raw
-    go prec left = 
+    go prec left =
      do
        op <- token Oper
        let Just (p,fix) = lookup op operators
@@ -115,8 +116,8 @@ letExpr = do
  alts <- startBlock $ someSame $ letAssign
  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  
+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
-