Primitive "Add missing cases" for vscode

src/Lib/Common.newt

@@ -14,7 +14,10 @@ record Bounds where
 
 -- FIXME we should handle overlap and out of order..
 instance Add Bounds where
-  a + b = MkBounds a.startLine a.startCol b.endLine b.endCol
+  a + b =
+    let a' = if a.startLine < b.startLine  || a.startLine == b.startLine && a.startCol < b.startCol then a else b
+        b' = if a.endLine < b.endLine || a.endLine == b.endLine && a.endCol < b.endCol then b else a
+    in MkBounds a'.startLine a'.startCol b'.endLine b'.endCol
 
 instance Eq Bounds where
   (MkBounds sl sc el ec) == (MkBounds sl' sc' el' ec') =
@@ -103,6 +106,9 @@ record FC where
   bnds : Bounds
 
 
+instance Add FC where
+  MkFC fn a + MkFC _ b = MkFC fn (a + b)
+
 instance ToJSON FC where
   toJson (MkFC file (MkBounds line col endline endcol)) = JsonObj (("file", toJson file) :: ("line", toJson line) :: ("col", toJson col) :: ("endline", toJson endline) :: ("endcol", toJson endcol):: Nil)
 
@@ -132,6 +138,9 @@ emptyFC' fn = MkFC fn (MkBounds 0 0 0 0)
 data QName : U where
   QN : List String -> String -> QName
 
+.baseName : QName → String
+(QN _ name).baseName = name
+
 instance Eq QName where
   -- `if` gets us short circuit behavior, idris has a lazy `&&`
   QN ns n == QN ns' n' = if n == n' then ns == ns' else False
@@ -159,7 +168,8 @@ showError src (E fc msg) = "ERROR at \{show fc}: \{msg}\n" ++ go 0 (lines src)
     go l Nil = ""
     go l (x :: xs) =
       if l == fcLine fc then
-        "  \{x}\n  \{replicate (cast $ fcCol fc) ' '}^\n"
+        let width = fc.bnds.endCol - fc.bnds.startCol + 1 in
+        "  \{x}\n  \{replicate (cast $ fcCol fc) ' '}\{replicate (cast width) '^'}\n"
       else if fcLine fc - 3 < l then "  " ++ x ++ "\n" ++ go (l + 1) xs
       else go (l + 1) xs
 showError src (Postpone fc ix msg) = "ERROR at \{show fc}: Postpone \{show ix} \{msg}\n" ++ go 0 (lines src)

src/Lib/Elab.newt

@@ -990,7 +990,7 @@ mkPat (tm, icit) = do
                 (Just (MkEntry _ name type (DCon _ _ k str) _)) => do
                   -- TODO check arity, also figure out why we need reverse
                   bpat <- traverse (mkPat) b
-                  pure $ PatCon fc icit name bpat Nothing
+                  pure $ PatCon (getFC tm) icit name bpat Nothing
                 -- This fires when a global is shadowed by a pattern var
                 -- Just _ => error (getFC tm) "\{show nm} is not a data constructor"
                 _ => case b of
@@ -1144,9 +1144,27 @@ buildLitCase ctx prob fc scnm scty lit = do
 buildDefault : Context → Problem → FC → String → List QName → M CaseAlt
 buildDefault ctx prob fc scnm missing = do
   let defclauses = filter isDefault prob.clauses
-  when (length' defclauses == 0) $ \ _ => error fc "missing cases \{show missing} on \{show scnm}"
+  -- HACK - For missing cases, we leave enough details in the error message to enable
+  -- the editor to add them
+  -- We can't do this precisely without a better pretty printer.
+  when (length' defclauses == 0) $ \ _ => do
+      missing <- traverse applied missing
+      error fc "missing cases: \{show missing}"
   CaseDefault <$> buildTree ctx (MkProb defclauses prob.ty)
   where
+    -- apply a dcon to _ for each explicit argument
+    applied : QName → M String
+    applied qn = do
+      top <- getTop
+      case lookup qn top of
+        Just (MkEntry _ _ ty (DCon _ _ _ _) _) => pure $ go qn.baseName ty
+        _ => pure qn.baseName
+      where
+        go : String → Tm → String
+        go acc (Pi _ _ Explicit _ _ t) = go "\{acc} _" t
+        go acc (Pi _ _ _ _ _ t) = go acc t
+        go acc _ = acc
+
     isDefault : Clause -> Bool
     isDefault cl = case find ((_==_ scnm) ∘ fst) cl.cons of
       Just (_, (PatVar _ _ _)) => True

src/Lib/Parser.newt

@@ -74,7 +74,7 @@ interpString = do
     append : Raw -> Raw -> Raw
     append t u =
       let fc = getFC t in
-      (RApp (getFC t) (RApp fc (RVar fc "_++_") t Explicit) u Explicit)
+      (RApp (fc + getFC u) (RApp fc (RVar fc "_++_") t Explicit) u Explicit)
 
 intLit : Parser Raw
 intLit = do
@@ -166,19 +166,18 @@ pratt ops prec stop left spine = do
         case lookupMap' nm ops of
           Just (MkOp name p fix False rule) => if p < prec
             then pure (left, spine)
-            else
-              runRule p fix stop rule (RApp fc (RVar fc name) left Explicit) rest
+            else runRule p fix stop rule (RApp (getFC left + fc) (RVar fc name) left Explicit) rest
           Just _ => fail "expected operator"
           Nothing =>
             if isPrefixOf "." nm
-            then pratt ops prec stop (RApp (getFC tm) tm left Explicit) rest
-            else pratt ops prec stop (RApp (getFC left) left tm Explicit) rest
-    ((icit, fc, tm) :: rest) => pratt ops prec stop (RApp (getFC left) left tm icit) rest
+            then pratt ops prec stop (RApp (getFC left + getFC tm) tm left Explicit) rest
+            else pratt ops prec stop (RApp (getFC left + getFC tm) left tm Explicit) rest
+    ((icit, fc, tm) :: rest) => pratt ops prec stop (RApp (getFC left + getFC tm) left tm icit) rest
   where
     projectHead : Raw -> AppSpine -> (Raw × AppSpine)
     projectHead t sp@((Explicit, fc', RVar fc nm) :: rest) =
       if isPrefixOf "." nm
-        then projectHead (RApp fc (RVar fc nm) t Explicit) rest
+        then projectHead (RApp (fc + getFC t) (RVar fc nm) t Explicit) rest
         else (t,sp)
     projectHead t sp = (t, sp)
 
@@ -188,7 +187,7 @@ pratt ops prec stop left spine = do
     runProject : AppSpine -> AppSpine
     runProject (t@(Explicit, fc', tm) :: u@(Explicit, _, RVar fc nm) :: rest) =
       if isPrefixOf "." nm
-        then runProject ((Explicit, fc', RApp fc (RVar fc nm) tm Explicit) :: rest)
+        then runProject ((Explicit, fc', RApp (fc + getFC tm) (RVar fc nm) tm Explicit) :: rest)
         else (t :: u :: rest)
     runProject tms = tms
 
@@ -203,7 +202,7 @@ pratt ops prec stop left spine = do
       case spine of
                 ((_, fc, right) :: rest) => do
                   (right, rest) <- pratt ops pr stop right rest
-                  pratt ops prec stop (RApp (getFC left) left right Explicit) rest
+                  pratt ops prec stop (RApp (getFC left + getFC right) left right Explicit) rest
                 _ => fail "trailing operator"
 
     runRule p fix stop (nm :: rule) left spine = do
@@ -215,7 +214,7 @@ pratt ops prec stop left spine = do
           let ((_,fc',RVar fc name) :: rest) = rest
             | _ => fail "expected \{nm}"
           if name == nm
-            then runRule p fix stop rule (RApp (getFC left) left right Explicit) rest
+            then runRule p fix stop rule (RApp (getFC left + getFC right) left right Explicit) rest
             else fail "expected \{nm}"
 
     -- run any prefix operators
@@ -417,7 +416,9 @@ term = do
   where
     apply : Raw -> List (FC × Raw) -> Raw
     apply t Nil = t
-    apply t ((fc,x) :: xs) = RApp fc t (apply x xs) Explicit
+    apply t ((fc,x) :: xs) =
+      let u = apply x xs in
+      RApp (getFC t + getFC u) t u Explicit
 
 varname : Parser String
 varname = (ident <|> uident <|> keyword "_" *> pure "_")