Highlight error part in REPL (#1957)

Closes #1956
swarm-game · Jun 19, 2024 · 6a4ddb3 · 6a4ddb3
1 parent 53fe43d
commit 6a4ddb3
Show file tree

Hide file tree

Showing 3 changed files with 41 additions and 13 deletions.
diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs
@@ -54,7 +54,6 @@ import Control.Monad.Extra (whenJust)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.State (MonadState, execState)
 import Data.Bits
-import Data.Either (isRight)
 import Data.Foldable (toList)
 import Data.Int (Int32)
 import Data.List.NonEmpty (NonEmpty (..))
@@ -94,16 +93,31 @@ import Swarm.Game.State.Robot
 import Swarm.Game.State.Runtime
 import Swarm.Game.State.Substate
 import Swarm.Game.Step (finishGameTick, gameTick)
-import Swarm.Language.Capability (Capability (CGod, CMake), constCaps)
+import Swarm.Language.Capability (
+  Capability (CGod, CMake),
+  constCaps,
+ )
 import Swarm.Language.Context
 import Swarm.Language.Key (KeyCombo, mkKeyCombo)
 import Swarm.Language.Module (moduleSyntax)
+import Swarm.Language.Parser (readTerm')
+import Swarm.Language.Parser.Core (defaultParserConfig)
 import Swarm.Language.Parser.Lex (reservedWords)
-import Swarm.Language.Pipeline (Contexts (..), ProcessedTerm (..), processTerm', processedSyntax)
+import Swarm.Language.Parser.Util (showErrorPos)
+import Swarm.Language.Pipeline (
+  Contexts (..),
+  ProcessedTerm (..),
+  processParsedTerm',
+  processTerm',
+  processedSyntax,
+ )
 import Swarm.Language.Pipeline.QQ (tmQ)
 import Swarm.Language.Pretty
 import Swarm.Language.Requirement qualified as R
 import Swarm.Language.Syntax hiding (Key)
+import Swarm.Language.Typecheck (
+  ContextualTypeErr (..),
+ )
 import Swarm.Language.Typed (Typed (..))
 import Swarm.Language.Types
 import Swarm.Language.Value (Value (VExc, VKey, VUnit), prettyValue, stripVResult)
@@ -1316,12 +1330,16 @@ validateREPLForm s =
     CmdPrompt _
       | otherwise ->
           let ctxs = Contexts (topCtx ^. defTypes) (topCtx ^. defReqs) (topCtx ^. tydefVals)
-              result = processTerm' ctxs uinput
-              theType = case result of
-                Right (Just pt) -> Just (pt ^. processedSyntax . sType)
-                _ -> Nothing
+              (theType, errSrcLoc) = case readTerm' defaultParserConfig uinput of
+                Left err ->
+                  let ((_y1, x1), (_y2, x2), _msg) = showErrorPos err
+                   in (Nothing, Left (SrcLoc x1 x2))
+                Right Nothing -> (Nothing, Right ())
+                Right (Just theTerm) -> case processParsedTerm' ctxs theTerm of
+                  Right t -> (Just (t ^. processedSyntax . sType), Right ())
+                  Left err -> (Nothing, Left (cteSrcLoc err))
            in s
-                & uiState . uiGameplay . uiREPL . replValid .~ isRight result
+                & uiState . uiGameplay . uiREPL . replValid .~ errSrcLoc
                 & uiState . uiGameplay . uiREPL . replType .~ theType
     SearchPrompt _ -> s
  where

diff --git a/src/swarm-tui/Swarm/TUI/Model/Repl.hs b/src/swarm-tui/Swarm/TUI/Model/Repl.hs
@@ -63,6 +63,7 @@ import Data.Text qualified as T
 import Data.Text.Zipper qualified as TZ
 import Servant.Docs (ToSample)
 import Servant.Docs qualified as SD
+import Swarm.Language.Syntax (SrcLoc (..))
 import Swarm.Language.Types
 import Swarm.TUI.Model.Name
 import Swarm.Util.Lens (makeLensesNoSigs)
@@ -274,7 +275,7 @@ data ReplControlMode
 data REPLState = REPLState
   { _replPromptType :: REPLPrompt
   , _replPromptEditor :: Editor Text Name
-  , _replValid :: Bool
+  , _replValid :: Either SrcLoc ()
   , _replLast :: Text
   , _replType :: Maybe Polytype
   , _replControlMode :: ReplControlMode
@@ -293,7 +294,7 @@ initREPLState hist =
   REPLState
     { _replPromptType = defaultPrompt
     , _replPromptEditor = newREPLEditor ""
-    , _replValid = True
+    , _replValid = Right ()
     , _replLast = ""
     , _replType = Nothing
     , _replControlMode = Typing
@@ -317,7 +318,9 @@ replPromptText = lens g s
   s r t = r & replPromptEditor .~ newREPLEditor t
 
 -- | Whether the prompt text is a valid 'Swarm.Language.Syntax.Term'.
-replValid :: Lens' REPLState Bool
+--   If it is invalid, the location of error. ('NoLoc' means the whole
+--   text causes the error.)
+replValid :: Lens' REPLState (Either SrcLoc ())
 
 -- | The type of the current REPL input which should be displayed to
 --   the user (if any).

diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs
@@ -1540,11 +1540,18 @@ renderREPLPrompt focus theRepl = ps1 <+> replE
  where
   prompt = theRepl ^. replPromptType
   replEditor = theRepl ^. replPromptEditor
-  color = if theRepl ^. replValid then id else withAttr redAttr
+  color t =
+    case theRepl ^. replValid of
+      Right () -> txt t
+      Left NoLoc -> withAttr redAttr (txt t)
+      Left (SrcLoc s e) | s == e || s >= T.length t -> withAttr redAttr (txt t)
+      Left (SrcLoc s e) ->
+        let (validL, (invalid, validR)) = T.splitAt (e - s) <$> T.splitAt s t
+         in hBox [txt validL, withAttr redAttr (txt invalid), txt validR]
   ps1 = replPromptAsWidget (T.concat $ getEditContents replEditor) prompt
   replE =
     renderEditor
-      (color . vBox . map txt)
+      (vBox . map color)
       (focusGetCurrent focus `elem` [Nothing, Just (FocusablePanel REPLPanel), Just REPLInput])
       replEditor