add missing and case split for lsp

src/Commands.newt

@@ -10,6 +10,9 @@ import Data.List1
 import Lib.Tokenizer
 import Lib.Token
 import Lib.Elab
+import Data.String
+import Lib.Eval
+import Data.SortedMap
 
 -- For now we cheat and assume capitalized directories are a module component
 decomposeName : String → String × String
@@ -31,7 +34,8 @@ getHoverInfo repo modns row col = do
     mod <- processModule emptyFC repo Nil modns
 
     -- not necessarily loaded into top... (Maybe push this down into that branch of processModule)
-    modifyTop [ defs := mod.modDefs; metaCtx := mod.modMetaCtx; ops := mod.ctxOps; imported := mod.modDeps ]
+    -- FIXME - fragile - this is why we don't want this stuff directly in TopContext
+    modifyTop [ defs := mod.modDefs; metaCtx := mod.modMetaCtx; ops := mod.ctxOps; imported := mod.modDeps; infos := mod.modInfos]
     top <- getTop
 
     -- Find the token at the point
@@ -50,3 +54,117 @@ getHoverInfo repo modns row col = do
         getTok (tok :: toks) =
             if tok.bounds.startCol <= col && (col <= tok.bounds.endCol)
             then Just $ value tok else getTok toks
+
+data FileEdit = MkEdit FC String
+data CodeAction
+  = CaseSplitAction (List FileEdit)
+  | AddMissingAction (List FileEdit)
+
+
+applyDCon : QName × Int × Tm → List String
+applyDCon (QN _ nm, _, tm) = go (Lin :< nm) tm
+  where
+    go : SnocList String → Tm → List String
+    go acc (Pi _ nm Explicit _ _ u) = go (acc :< nm) u
+    go acc (Pi _ _ _ _ _ u) = go acc u
+    go acc _ = acc <>> Nil
+
+-- Not quite right, we also need to check for let...
+-- But it's a first pass
+splitEquals : SnocList Char → List Char → (Bool × String × String)
+splitEquals acc Nil = (True, pack (acc <>> Nil), "")
+splitEquals acc xs@('=' :: _) = (True, pack (acc <>> Nil), pack xs)
+splitEquals acc xs@('<' :: '-' :: _) = (False, pack (acc <>> Nil), pack xs)
+splitEquals acc (x :: xs) = splitEquals (acc :< x) xs
+
+needParens : SnocList Char → List Char → Bool
+needParens (xs :< ' ') ys = needParens xs ys
+needParens xs (' ' :: ys) = needParens xs ys
+needParens (xs :< '(') (')' :: ys) = False
+needParens _ _ = True
+
+addParens : Bool → List String → String
+addParens _ (x :: Nil) = x
+addParens False s = unwords s
+addParens True s = "(\{unwords s})"
+
+-- REVIEW - maybe pass in QName and use applyDCon in here, especially if we want to get better names?
+makeEdits : FC → List QName → Bool → M (List FileEdit)
+makeEdits fc@(MkFC uri (MkBounds sr sc er ec)) names inPlace = do
+  cons <- map applyDCon <$> traverse lookupDCon names
+  top <- getTop
+  let (Just mod) = lookupMap' top.ns top.modules | _ => pure Nil
+  let lines = split mod.modSource "\n"
+  let (Just line) = getAt' sr lines | _ => pure Nil
+  let cs = unpack line
+  let head = take (cast sc) cs
+  let tail = drop (S $ cast ec) cs
+  let (isEq, before, after) = splitEquals Lin tail
+  let np = needParens (Lin <>< head) tail
+  let cons = map (addParens np) cons
+  let phead = pack head
+
+  -- No init or first :: rest for add missing case
+  let (edits, rest) = doFirst inPlace cons
+
+  let phead = pack head
+  let fc' = MkFC uri (MkBounds (sr + 1) 0 (sr + 1) 0)
+  let srest =
+    if isEq
+      then joinBy "" $ map (\ap => phead ++ ap ++ before ++ "= ?\n") rest
+      else joinBy "" $ map (\ap => "  | \{pack head}\{ap}\{before}=> ?\n") rest
+
+  putStrLn "Split \{show line} HD '\{show head}' TL '\{show tail}'"
+  putStrLn srest
+  let edits = MkEdit fc' (srest) :: edits
+  putStrLn "edits \{debugStr edits}"
+  pure edits
+  where
+    doFirst : Bool → List String → (List FileEdit × List String)
+    doFirst True (first :: rest) = (MkEdit fc first :: Nil, rest)
+    doFirst _ cons = (Nil, cons)
+
+addMissingCases : Int → Int → FC → Context → List QName → M (Maybe CodeAction)
+addMissingCases _ _ fc@(MkFC uri (MkBounds sr sc er ec)) ctx names = do
+  top <- getTop
+  edits <- makeEdits fc names False
+  putStrLn "Add Missing \{show fc} \{show names}"
+  pure $ Just $ AddMissingAction edits
+
+getCaseSplit : Int → Int → FC → Context → String → Val → M (Maybe CodeAction)
+getCaseSplit row col fc@(MkFC uri (MkBounds sr sc er ec)) ctx nm scty = do
+  top <- getTop
+  -- It's getting vars for the type
+  scty <- unlet ctx.env scty
+  cons <- getConstructors ctx fc scty
+  ty <- quote (length' ctx.env) scty
+  cons <- filterM (checkCase ctx nm scty) cons
+  let names = map fst cons
+  edits <- makeEdits fc names True
+  pure $ Just $ CaseSplitAction edits
+
+posInFC : Int → Int → FC → Bool
+-- FIXME ec + 1 again...
+posInFC row col (MkFC _ (MkBounds sr sc er ec)) = (sr <= row && row <= er) && (sc <= col && col <= ec + 1)
+
+getActions : FileSource → String → Int → Int → M (List CodeAction)
+getActions repo modns row col = do
+  mod <- processModule emptyFC repo Nil modns
+  -- not necessarily loaded into top... (Maybe push this down into that branch of processModule)
+  modifyTop [ defs := mod.modDefs; metaCtx := mod.modMetaCtx; ops := mod.ctxOps; imported := mod.modDeps; infos := mod.modInfos]
+  top <- getTop
+  let xx = filter (posInFC row col ∘ getFC) top.infos
+  putStrLn "Filter got \{show $ length' xx}"
+  go Nil $ xx
+  where
+    getAction : EditorInfo → M (Maybe CodeAction)
+    getAction (CaseSplit fc ctx nm scty) = getCaseSplit row col fc ctx nm scty
+    getAction (MissingCases fc ctx names) = addMissingCases row col fc ctx names
+
+    go : List CodeAction → List EditorInfo → M (List CodeAction)
+    go acc Nil = pure acc
+    go acc (x :: xs) = do
+      Right (Just res) <- tryError $ getAction x
+        | _ => go acc xs
+      go (res :: acc) xs
+

src/LSP.newt

@@ -81,9 +81,14 @@ updateFile fn src = unsafePerformIO $ do
     modifyIORef state [ topContext := ctx ]
 
 
+-- FIXME - this is an issue - FC doesn't distinguish empty and length 1.
+-- Need to put the +1 on FC itself.
 fcToRange : FC → Json
 fcToRange (MkFC uri (MkBounds sr sc er ec)) =
-    JsonObj $ ("start", mkPosition sr sc) :: ("end", mkPosition er (ec + 1)) :: Nil
+    if sc == 0 && ec == 0
+      -- For the insert position in edits
+      then JsonObj $ ("start", mkPosition sr sc) :: ("end", mkPosition er (ec)) :: Nil
+      else JsonObj $ ("start", mkPosition sr sc) :: ("end", mkPosition er (ec + 1)) :: Nil
     where
         mkPosition : Int → Int → Json
         mkPosition l c = JsonObj $ ("line", JsonInt l) :: ("character", JsonInt c) :: Nil
@@ -96,6 +101,7 @@ hoverInfo uri line col = unsafePerformIO $ do
     if (st.baseDir /= base)
         then resetState base
         else pure MkUnit
+    st <- readIORef state
     -- We're proactively running check if there is no module information, make sure we save it
     Right (top, Just (msg, fc)) <- (getHoverInfo lspFileSource modns line col).runM st.topContext
         | Right (top, _)  => do
@@ -109,6 +115,45 @@ hoverInfo uri line col = unsafePerformIO $ do
     let location = JsonObj $ ("uri", JsonStr fc.file) :: ("range", fcToRange fc) :: Nil
     pure $ jsonToJObject $ JsonObj $ ("info", JsonStr msg) :: ("location", location) :: Nil
 
+codeActionInfo : String → Int → Int → JSObject
+codeActionInfo uri line col = unsafePerformIO $ do
+  let (base,modns) = decomposeName uri
+  putStrLn "Action \{uri} base \{base} mod \{modns}"
+  st <- readIORef state
+  if (st.baseDir /= base) then resetState base else pure MkUnit
+  st <- readIORef state
+  Right (top, actions) <- (do
+    actions <- getActions lspFileSource modns line col
+    putStrLn "\{show $ length' actions} actions"
+    pure actions).runM st.topContext
+    | Left err => do
+      putStrLn $ showError "" err
+      pure js_null
+  modifyIORef state $ [ topContext := top ]
+  pure $ jsonToJObject $ JsonArray $ map actionToJson actions
+  where
+    single : String → Json → Json
+    single k v = JsonObj $ (k,v) :: Nil
+
+    editToJson : FileEdit → Json
+    editToJson (MkEdit fc text) =
+      JsonObj
+        $ ("range", fcToRange fc)
+        :: ("newText", JsonStr text)
+        :: Nil
+
+    actionToJson : CodeAction → Json
+    actionToJson (CaseSplitAction edits) =
+      JsonObj
+        $ ("title", JsonStr "Case split")
+        :: ("edit", (single "changes" $ single uri $ JsonArray $ map editToJson edits))
+        :: Nil
+    actionToJson (AddMissingAction edits) =
+      JsonObj
+        $ ("title", JsonStr "Add missing cases")
+        :: ("edit", (single "changes" $ single uri $ JsonArray $ map editToJson edits))
+        :: Nil
+
 errorToDiag : Error -> Json
 errorToDiag (E fc msg) =
   JsonObj
@@ -173,4 +218,5 @@ checkFile fn = unsafePerformIO $ do
 -- This seems like a hack, but it works.
 -- Dummy main function with references to force functions into ouput file.
 -- but we don't get `export` on it..
-pfunc main uses (updateFile checkFile hoverInfo) : IO Unit  := `() => {}`
+-- #export updateFile checkFile hoverInfo
+pfunc main uses (updateFile checkFile hoverInfo codeActionInfo) : IO Unit  := `() => {}`

src/Lib/Elab.newt

@@ -245,8 +245,6 @@ solveAutos = do
       res <- trySolveAuto e
       if res then pure True else run es
 
--- We need to switch to SortedMap here
-
 updateMeta : QName -> (MetaEntry -> M MetaEntry) -> M Unit
 updateMeta ix f = do
   top <- getTop
@@ -713,6 +711,14 @@ findSplit (x@(PC nm (PatCon _ _ _ _ _) _) :: xs) = Just x
 findSplit (x@(PC nm (PatLit _ val) _) :: xs) = Just x
 findSplit (x :: xs) = findSplit xs
 
+lookupDCon : QName -> M (QName × Int × Tm)
+lookupDCon nm = do
+  top <- getTop
+  case lookup nm top of
+    (Just (MkEntry _ name type (DCon _ _ k str) _)) => pure (name, length' k, type)
+    Just _ => error emptyFC "Internal Error: \{show nm} is not a DCon"
+    Nothing => error emptyFC "Internal Error: DCon \{show nm} not found"
+
 -- Get the constructors for a type
 getConstructors : Context -> FC -> Val -> M (List (QName × Int × Tm))
 getConstructors ctx scfc (VRef fc nm _) = do
@@ -725,13 +731,7 @@ getConstructors ctx scfc (VRef fc nm _) = do
       case lookup nm top of
         (Just (MkEntry _ name type (TCon _ names) _)) => pure names
         _ => error scfc "Not a type constructor: \{show nm}"
-    lookupDCon : QName -> M (QName × Int × Tm)
-    lookupDCon nm = do
-      top <- getTop
-      case lookup nm top of
-        (Just (MkEntry _ name type (DCon _ _ k str) _)) => pure (name, length' k, type)
-        Just _ => error fc "Internal Error: \{show nm} is not a DCon"
-        Nothing => error fc "Internal Error: DCon \{show nm} not found"
+
 getConstructors ctx scfc tm = do
   tms <- vprint ctx tm
   error scfc "Can't split - not VRef: \{tms}"
@@ -1088,9 +1088,15 @@ checkDone fc ctx Nil (Just body) ty = do
   got <- check ctx body ty
   debug $ \ _ => "DONE<- got \{rpprint (names ctx) got}"
   pure got
-checkDone fc ctx (PC x (PatWild _ _) scty :: xs) body ty = checkDone fc ctx xs body ty
-checkDone fc ctx (PC nm (PatVar _ _ nm') scty :: xs) body ty =
-  let ctx = MkCtx ctx.lvl ctx.env (rename ctx.types) ctx.bds ctx.ctxFC in
+checkDone fc ctx (PC x (PatWild pvfc icit) scty :: xs) body ty = do
+  -- sometimes have the same FC as real arguments
+  when (icit == Explicit) $ \ _ => addInfo $ CaseSplit pvfc ctx "_" scty
+  checkDone fc ctx xs body ty
+checkDone fc ctx (PC nm (PatVar pvfc _ nm') scty :: xs) body ty = do
+  -- TIME 5.50 -> 5.62 (we can flag this if it's an issue)
+  addInfo $ CaseSplit pvfc ctx nm' scty
+
+  let ctx = MkCtx ctx.lvl ctx.env (rename ctx.types) ctx.bds ctx.ctxFC
   checkDone fc ctx xs body ty
   where
     rename : List (String × Val) -> List (String × Val)
@@ -1182,26 +1188,13 @@ 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 (isDefaultCase scnm) prob.clauses
-  -- 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 _ nm Explicit _ _ t) = go "\{acc} \{nm}" t
-        go acc (Pi _ _ _ _ _ t) = go acc t
-        go acc _ = acc
+  case defclauses of
+    Nil => do
+      addInfo $ MissingCases fc ctx missing
+      addError $ E fc "missing cases: \{show missing}"
+      hole <- freshMeta ctx fc prob.ty ErrorHole
+      pure $ CaseDefault hole
+    _ => CaseDefault <$> buildTree ctx (MkProb defclauses prob.ty)
 
 buildLitCases : Context -> Problem -> FC -> String -> Val -> M (List CaseAlt)
 buildLitCases ctx prob fc scnm scty = do
@@ -1543,17 +1536,7 @@ check ctx tm ty = do
       unifyCatch (getFC tm) ctx ty' ty
       pure tm'
 
--- We assume the types are the same here, which looses some flexibility
--- This does not work because the meta is unsolved when `updateRecord` tries to do
--- its thing. We would need to defer elab to get this to work - insert placeholder
--- and solve it later.
-infer ctx tm@(RUpdateRec fc _ _) = do
-  error fc "I can't infer record updates"
-  -- mvar <- freshMeta ctx fc (VU emptyFC) Normal
-  -- a <- eval ctx.env mvar
-  -- let ty = VPi fc ":ins" Explicit Many a (MkClosure ctx.env mvar)
-  -- tm <- check ctx tm ty
-  -- pure (tm, ty)
+infer ctx tm@(RUpdateRec fc _ _) = error fc "I can't infer record updates"
 
 infer ctx (RVar fc nm) = go 0 ctx.types
   where
@@ -1601,7 +1584,7 @@ infer ctx (RApp fc t u icit) = do
       -- If it's not a VPi, try to unify it with a VPi
       -- TODO test case to cover this.
       tty => do
-        debug $ \ _ => "unify PI for \{show tty}"
+        debug $ \ _ => "unify PI for \{show tty} at \{show $ getFC tty}"
         a <- freshMeta ctx fc (VU emptyFC) Normal >>= eval ctx.env
         b <- MkClosure ctx.env <$> freshMeta (extend ctx ":ins" a) fc (VU emptyFC) Normal
         -- FIXME - I had to guess Many here.  What are the side effects?

src/Lib/Erasure.newt

@@ -96,7 +96,7 @@ erase env t sp = case t of
   (Bnd fc k) => do
     case getAt (cast k) env of
       Nothing => error fc "bad index \{show k}"
-      Just (nm, Zero, ty) => error fc "used erased value \{show nm} (FIXME FC may be wrong here - see Elab.lookupName)"
+      Just (nm, Zero, ty) => error fc "used erased value \{show nm} (FIXME FC may be wrong here)"
       Just (nm, Many, ty) => eraseSpine env t sp ty
   (UU fc) => eraseSpine env t sp (Just $ UU fc)
   (Lit fc lit) => eraseSpine env t sp Nothing

src/Lib/ProcessModule.newt

@@ -21,7 +21,7 @@ addPrimitives = do
   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
   top <- getTop
-  let mod = MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops Nil top.errors
+  let mod = MkModCtx "" top.defs (MC emptyMap Nil 0 CheckAll) top.ops Nil top.errors Nil
   let modules = updateMap primNS mod top.modules
   -- TODO - do we clear this? Try just modules := modules, but wait until this refactor is done.
   modifyTop [ modules := modules
@@ -106,11 +106,12 @@ processModule importFC repo stk modns = do
   top <- getTop
   let freshMC = MC emptyMap Nil 0 CheckAll
   -- NOW Print and drop errors here
-  -- set imported, mod, freshMC, ops  before processing
+  -- clear per module fields before processing this module
   modifyTop [ imported := imported
             ; hints := emptyMap
             ; ns := modns
             ; defs := emptyMap
+            ; infos := Nil
             ; metaCtx := freshMC
             ; ops := ops
             ]
@@ -124,7 +125,7 @@ processModule importFC repo stk modns = do
   -- update modules with result, leave the rest of context in case this is top file
   top <- getTop
 
-  let mod = MkModCtx src top.defs top.metaCtx top.ops imported top.errors
+  let mod = MkModCtx src top.defs top.metaCtx top.ops imported top.errors top.infos
 
   let modules = updateMap modns mod top.modules
   modifyTop [modules := modules]
@@ -159,5 +160,4 @@ invalidateModule modname = do
     go deps (name :: names) = do
       modifyTop [modules $= deleteMap name]
       let ds = fromMaybe Nil $ lookupMap' name deps
-      putStrLn "Chase \{name} → \{show ds}"
       go deps $ ds ++ names

src/Lib/TopContext.newt

@@ -47,7 +47,7 @@ instance Show TopContext where
   show top = "\nContext:\n [\{ joinBy "\n" $ map (show ∘ snd) $ toList top.defs}]"
 
 emptyTop : TopContext
-emptyTop = MkTop emptyMap Nil emptyMap "" emptyMap (MC emptyMap Nil 0 CheckAll) 0 Nil emptyMap
+emptyTop = MkTop emptyMap Nil emptyMap Nil "" emptyMap (MC emptyMap Nil 0 CheckAll) 0 Nil emptyMap
 
 
 setFlag : QName → FC → EFlag → M Unit
@@ -94,4 +94,9 @@ addHint qn = do
 addError : Error -> M Unit
 addError err = do
   top <- getTop
-  modifyTop [ errors $= _::_ err ]
+  modifyTop [ errors $= (err ::) ]
+
+addInfo : EditorInfo → M Unit
+addInfo info = do
+  top <- getTop
+  modifyTop [ infos $= (info ::)]

src/Lib/Types.newt

@@ -294,17 +294,19 @@ showClosure (MkClosure xs t) = "(%cl [\{show $ length xs} env] \{show t})"
 
 Context : U
 
-data MetaKind = Normal | User | AutoSolve
+data MetaKind = Normal | User | AutoSolve | ErrorHole
 
 instance Show MetaKind where
   show Normal = "Normal"
   show User = "User"
   show AutoSolve = "Auto"
+  show ErrorHole = "ErrorHole"
 
 instance Eq MetaKind where
   Normal == Normal = True
   User == User = True
   AutoSolve == AutoSolve = True
+  ErrorHole == ErrorHole = True
   _ == _ = False
 
 -- constrain meta applied to val to be a val
@@ -394,6 +396,11 @@ record TopEntry where
 instance Show TopEntry where
   show (MkEntry fc name type def flags) = "\{show name} : \{show type} := \{show def} \{show flags}"
 
+data EditorInfo
+  = CaseSplit FC Context String Val
+  -- Not sure we need Context here?
+  | MissingCases FC Context (List QName)
+
 record ModContext where
   constructor MkModCtx
   modSource : String
@@ -404,6 +411,7 @@ record ModContext where
   ctxOps : Operators
   modDeps : List String
   modErrors : List Error
+  modInfos : List EditorInfo
 
 -- Top level context.
 -- Most of the reason this is separate is to have a different type
@@ -414,17 +422,25 @@ record ModContext where
 
 -- A placeholder while walking through dependencies of a module
 emptyModCtx : String → ModContext
-emptyModCtx csum = MkModCtx csum emptyMap (MC emptyMap Nil 0 NoCheck) emptyMap Nil Nil
+emptyModCtx source = MkModCtx source emptyMap (MC emptyMap Nil 0 NoCheck) emptyMap Nil Nil Nil
 
 HintTable : U
 HintTable = SortedMap QName (List (QName × Tm))
 
+
+-- DERIVE - HasFC would be an example of a user-defined derived
+instance HasFC EditorInfo where
+  getFC (CaseSplit fc _ _ _) = fc
+  getFC (MissingCases fc _ _) = fc
+
+
 record TopContext where
   constructor MkTop
   modules : SortedMap String ModContext
   imported : List String
   -- TCon name → function name × type
   hints : HintTable
+  infos : List EditorInfo
 
   -- current module
   ns : String