Use SrcSpan instead of SourcePos for UPLC in debugger (#5105)

plutus-core/executables/debugger/Event.hs

@@ -8,7 +8,6 @@
 module Event where
 
 import Annotation
-import PlutusCore qualified as PLC
 import PlutusCore.Pretty qualified as PLC
 import Types
 import UntypedPlutusCore qualified as UPLC
@@ -21,11 +20,9 @@ import Brick.Types qualified as B
 import Brick.Widgets.Edit qualified as BE
 import Control.Concurrent.MVar
 import Control.Monad.State
-import Data.Text qualified as Text
 import Graphics.Vty qualified as Vty
 import Lens.Micro
 import Prettyprinter
-import Text.Megaparsec
 
 handleDebuggerEvent :: MVar (D.Cmd Breakpoints)
                     -> B.BrickEvent ResourceName CustomBrickEvent
@@ -77,14 +74,15 @@ handleDebuggerEvent driverMailbox bev@(B.VtyEvent ev) = do
             pure ()
         _ -> handleEditorEvent
 handleDebuggerEvent _driverMailbox (B.AppEvent (UpdateClientEvent cekState)) = do
-    let mHighlightedTerm = case cekState of
-            Computing _ _ _ t -> Just (void t, UPLC.termAnn t)
-            Returning _ ctx v -> (dischargeCekValue v, ) <$> contextAnn ctx
-            _                 -> Nothing
-        uplcHighlight = do
-            (highlightedTerm, ann) <- mHighlightedTerm
-            let uplcPos = uplcAnn ann
-            pure $ mkUplcSpan uplcPos highlightedTerm
+    let uplcHighlight = do
+            uplcSpan <- uplcAnn <$> case cekState of
+                Computing _ _ _ t -> Just (UPLC.termAnn t)
+                Returning _ ctx _ -> contextAnn ctx
+                _                 -> Nothing
+            pure HighlightSpan
+                { _hcSLoc = B.Location (srcSpanSLine uplcSpan, srcSpanSCol uplcSpan),
+                  _hcELoc = Just $ B.Location (srcSpanELine uplcSpan, srcSpanECol uplcSpan)
+                }
     modify' $ \st -> case cekState of
         Computing{} ->
             st & dsUplcHighlight .~ uplcHighlight
@@ -111,29 +109,3 @@ handleDebuggerEvent _driverMailbox (B.AppEvent (UpdateClientEvent cekState)) = d
                     (PLC.render $ vcat ["Evaluation Finished. Result:", line, PLC.prettyPlcDef t])
         Starting{} -> st
 handleDebuggerEvent _ _ = pure ()
-
--- | Attempt to highlight the first token of a Term. This is a temporary workaround.
---
--- Ideally we want to highlight the entire Term, but currently the UPLC parser only attaches
--- a @SourcePos@ to each Term, while we'd need it to attach a @SrcSpan@.
-mkUplcSpan
-    :: PLC.SourcePos ->
-    D.DTerm UPLC.DefaultUni UPLC.DefaultFun ann ->
-    HighlightSpan
-mkUplcSpan pos term = HighlightSpan sloc eloc
-    where
-        sline = unPos $ sourceLine pos
-        scol = unPos $ sourceColumn pos
-        sloc = B.Location (sline, scol)
-        eline = sline
-        ecol = scol + delta - 1
-        eloc = Just $ B.Location (eline, ecol)
-        delta = length $ case term of
-            UPLC.Var _ name -> Text.unpack $ UPLC.ndbnString name
-            UPLC.LamAbs{}   -> "lam"
-            UPLC.Apply{}    -> "["
-            UPLC.Force{}    -> "force"
-            UPLC.Delay{}    -> "delay"
-            UPLC.Constant{} -> "con"
-            UPLC.Builtin{}  -> "builtin"
-            UPLC.Error{}    -> "error"

plutus-core/executables/debugger/Main.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE StrictData        #-}
+{-# LANGUAGE TupleSections     #-}
 {-# LANGUAGE TypeApplications  #-}
 
 {- | A Plutus Core debugger TUI application.
@@ -15,6 +16,7 @@
 -}
 module Main (main) where
 
+import Annotation
 import PlutusCore qualified as PLC
 import PlutusCore.Error
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
@@ -40,12 +42,15 @@ import Control.Monad.Except
 import Control.Monad.Extra
 import Control.Monad.ST (RealWorld)
 import Data.ByteString.Lazy qualified as Lazy
+import Data.Text (Text)
+import Data.Text qualified as Text
 import Data.Text.IO qualified as Text
 import Flat
 import Graphics.Vty qualified as Vty
 import Lens.Micro
 import Options.Applicative qualified as OA
 import System.Directory.Extra
+import Text.Megaparsec (unPos)
 
 debuggerAttrMap :: B.AttrMap
 debuggerAttrMap =
@@ -90,13 +95,30 @@ main = do
     unlessM (doesFileExist (optUplcPath opts)) . fail $
         "Does not exist or not a file: " <> optUplcPath opts
     uplcFlat <- Lazy.readFile (optUplcPath opts)
-    uplcDebruijn <- either (\e -> fail $ "UPLC deserialisation failure:" <> show e)
-        pure (unflat uplcFlat)
+    uplcDebruijn <-
+        either
+            (\e -> fail $ "UPLC deserialisation failure:" <> show e)
+            pure
+            (unflat uplcFlat)
     uplcNoAnn <- unDeBruijnProgram uplcDebruijn
     let uplcText = PLC.displayPlcDef uplcNoAnn
-    uplcSourcePos <- either (error . show @ParserErrorBundle) pure . PLC.runQuoteT $
-        UPLC.parseProgram uplcText
-    let uplc = fmap (\pos -> DAnn pos mempty) uplcSourcePos
+    uplcParsed <-
+        either (error . show @ParserErrorBundle) pure . PLC.runQuoteT $
+            UPLC.parseProgram uplcText
+    let uplc =
+            fmap
+                ( \(pos, token) ->
+                    let sp =
+                            SrcSpan
+                                { srcSpanFile = sourceName pos
+                                , srcSpanSLine = unPos (sourceLine pos)
+                                , srcSpanSCol = unPos (sourceColumn pos)
+                                , srcSpanELine = unPos (sourceLine pos)
+                                , srcSpanECol = unPos (sourceColumn pos) + Text.length token - 1
+                                }
+                     in DAnn sp mempty
+                )
+                $ zipProgramWithFirstToken uplcParsed
 
     hsText <- Text.readFile (optHsPath opts)
 
@@ -154,9 +176,10 @@ main = do
 
     void $ B.customMain initialVty builder (Just brickMailbox) app initialState
 
--- | The main entrypoint of the driver thread.
---
--- The driver operates in IO (not in BrickM): the only way to "influence" Brick is via the mailboxes
+{- | The main entrypoint of the driver thread.
+
+ The driver operates in IO (not in BrickM): the only way to "influence" Brick is via the mailboxes
+-}
 driverThread ::
     MVar (D.Cmd Breakpoints) ->
     B.BChan CustomBrickEvent ->
@@ -173,12 +196,13 @@ driverThread driverMailbox brickMailbox prog = do
         ?cekBudgetSpender = CekBudgetSpender $ \_ _ -> pure ()
         ?cekCosts = cekcosts
         ?cekSlippage = defaultSlippage
-      in D.iterM handle $ D.runDriver ndterm
+     in D.iterM handle $ D.runDriver ndterm
   where
-    -- | Peels off one Free monad layer
-    handle :: GivenCekReqs DefaultUni DefaultFun DAnn RealWorld
-           => D.DebugF DefaultUni DefaultFun DAnn Breakpoints (IO a)
-           -> IO a
+    -- \| Peels off one Free monad layer
+    handle ::
+        GivenCekReqs DefaultUni DefaultFun DAnn RealWorld =>
+        D.DebugF DefaultUni DefaultFun DAnn Breakpoints (IO a) ->
+        IO a
     handle = \case
         D.StepF prevState k  -> cekMToIO (D.handleStep prevState) >>= k
         D.InputF k           -> handleInput >>= k
@@ -190,9 +214,35 @@ driverThread driverMailbox brickMailbox prog = do
         handleLog = B.writeBChan brickMailbox . LogEvent
 
 unDeBruijnProgram ::
-    UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun ()
-    -> IO (UPLC.Program UPLC.Name DefaultUni DefaultFun ())
+    UPLC.Program UPLC.NamedDeBruijn DefaultUni DefaultFun () ->
+    IO (UPLC.Program UPLC.Name DefaultUni DefaultFun ())
 unDeBruijnProgram p = do
-    either (fail . show) pure . PLC.runQuote .
-        runExceptT @UPLC.FreeVariableError $
-            traverseOf UPLC.progTerm UPLC.unDeBruijnTerm p
+    either (fail . show) pure
+        . PLC.runQuote
+        . runExceptT @UPLC.FreeVariableError
+        $ traverseOf UPLC.progTerm UPLC.unDeBruijnTerm p
+
+zipProgramWithFirstToken ::
+    Program Name uni fun ann ->
+    Program Name uni fun (ann, Text)
+zipProgramWithFirstToken (Program ann ver t) =
+    Program (ann, "program") (fmap (,"program") ver) (zipTermWithFirstToken t)
+
+{- | Attempt to highlight the first token of a `Term`, by annotating the `Term` with
+ the first token of the pretty-printed `Term`. This is a temporary workaround.
+
+ Ideally we want to highlight the entire `Term`, but currently the UPLC parser only attaches
+ a `SourcePos` to each `Term`, while we'd need it to attach a `SrcSpan`.
+-}
+zipTermWithFirstToken :: Term Name uni fun ann -> Term Name uni fun (ann, Text)
+zipTermWithFirstToken = go
+  where
+    go = \case
+        Var ann name         -> Var (ann, UPLC._nameText name) name
+        LamAbs ann name body -> LamAbs (ann, "lam") name (go body)
+        Apply ann fun arg    -> Apply (ann, "[") (go fun) (go arg)
+        Force ann body       -> Force (ann, "force") (go body)
+        Delay ann body       -> Delay (ann, "delay") (go body)
+        Constant ann val     -> Constant (ann, "con") val
+        Builtin ann fun      -> Builtin (ann, "builtin") fun
+        Error ann            -> Error (ann, "error")

plutus-core/executables/debugger/Types.hs

@@ -17,6 +17,7 @@ import Brick.Widgets.Edit qualified as BE
 import Data.MonoTraversable
 import Data.Text (Text)
 import Lens.Micro.TH
+import Text.Megaparsec
 
 type Breakpoints = [Breakpoint]
 
@@ -26,7 +27,7 @@ data Breakpoint = UplcBP SourcePos
 -- | Annotation used in the debugger. Contains source locations for the UPLC program
 -- and the source program.
 data DAnn = DAnn
-    { uplcAnn :: SourcePos
+    { uplcAnn :: SrcSpan
     , txAnn   :: SrcSpans
     }
 
@@ -35,7 +36,7 @@ instance D.Breakpointable DAnn Breakpoints where
         where
           breakpointFired :: Breakpoint -> Bool
           breakpointFired = \case
-              UplcBP p -> sourceLine p == sourceLine (uplcAnn ann)
+              UplcBP p -> unPos (sourceLine p) == srcSpanSLine (uplcAnn ann)
               TxBP p   -> oany (lineInSrcSpan $ sourceLine p) $ txAnn ann
 
 -- | The custom events that can arrive at our brick mailbox.