PLT-1375: Highlight source code while tracing through Plutus Core

plutus-core/executables/debugger/Draw.hs

@@ -43,7 +43,7 @@ drawDebugger st =
         BB.borderWithLabel (B.txt "Source program") $
             B.withFocusRing
                 focusRing
-                (BE.renderEditor (B.txt . Text.unlines))
+                 (BE.renderEditor (drawDocumentWithHighlight (st ^. dsSourceHighlight)))
                 (st ^. dsSourceEditor)
     returnValueEditor =
         BB.borderWithLabel (B.txt "UPLC value being returned") $

plutus-core/executables/debugger/Event.hs

@@ -1,16 +1,13 @@
 {-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE TupleSections         #-}
 
 -- | Handler of debugger events.
 module Event where
 
 import PlutusCore.Annotation
 import PlutusCore.Pretty qualified as PLC
 import Types
-import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Evaluation.Machine.Cek.Debug.Driver qualified as D
 import UntypedPlutusCore.Evaluation.Machine.Cek.Debug.Internal
 
@@ -20,6 +17,8 @@ import Brick.Types qualified as B
 import Brick.Widgets.Edit qualified as BE
 import Control.Concurrent.MVar
 import Control.Monad.State
+import Data.Coerce
+import Data.Set as S
 import Graphics.Vty qualified as Vty
 import Lens.Micro
 import Prettyprinter
@@ -74,38 +73,43 @@ handleDebuggerEvent driverMailbox bev@(B.VtyEvent ev) = do
             pure ()
         _ -> handleEditorEvent
 handleDebuggerEvent _driverMailbox (B.AppEvent (UpdateClientEvent cekState)) = do
-    let uplcHighlight = do
-            uplcSpan <- uplcAnn <$> case cekState of
-                Computing _ _ _ t -> Just (UPLC.termAnn t)
-                Returning _ ctx _ -> contextAnn ctx
-                _                 -> Nothing
+    let uplcHighlight :: Maybe HighlightSpan = do
+            uplcSpan <- uplcAnn <$> cekStateAnn cekState
             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
+    let sourceHighlight :: Maybe HighlightSpan = do
+            txSpans <- txAnn <$> cekStateAnn cekState
+            -- FIXME: use some/all spans for highlighting, not just the first one
+            firstTxSpan <- S.lookupMin $ coerce txSpans
+            pure HighlightSpan
+                { _hcSLoc = B.Location (srcSpanSLine firstTxSpan, srcSpanSCol firstTxSpan),
+                  _hcELoc = Just $ B.Location (srcSpanELine firstTxSpan, srcSpanECol firstTxSpan)
+                }
+    modify' $
+      -- update line highlighting
+      set dsUplcHighlight uplcHighlight .
+      set dsSourceHighlight sourceHighlight .
+        case cekState of
+            Computing{} ->
                -- Clear the return value editor.
-               & dsReturnValueEditor .~
+               dsReturnValueEditor .~
                 BE.editorText
                     EditorReturnValue
                     Nothing
                     mempty
-        Returning _ _ v ->
-            st & dsUplcHighlight .~ uplcHighlight
-               & dsReturnValueEditor .~
+            Returning _ _ v ->
+               dsReturnValueEditor .~
                 BE.editorText
                     EditorReturnValue
                     Nothing
                     (PLC.displayPlcDef (dischargeCekValue v))
-
-        Terminating t ->
-            st & dsUplcHighlight .~ Nothing
-               & dsReturnValueEditor .~
+            Terminating t ->
+               dsReturnValueEditor .~
                 BE.editorText
                     EditorReturnValue
                     Nothing
                     (PLC.render $ vcat ["Evaluation Finished. Result:", line, PLC.prettyPlcDef t])
-        Starting{} -> st
+            Starting{} -> id
 handleDebuggerEvent _ _ = pure ()

plutus-core/executables/debugger/Main.hs

@@ -21,6 +21,8 @@ import PlutusCore.Annotation
 import PlutusCore.Error
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
 import PlutusCore.Evaluation.Machine.MachineParameters
+import PlutusCore.Executable.Common
+import PlutusCore.Executable.Parsers
 import PlutusCore.Pretty qualified as PLC
 import UntypedPlutusCore as UPLC
 import UntypedPlutusCore.Evaluation.Machine.Cek.Debug.Driver qualified as D
@@ -39,18 +41,15 @@ import Brick.Util qualified as B
 import Brick.Widgets.Edit qualified as BE
 import Control.Concurrent
 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)
+import UntypedPlutusCore.Core.Zip
 
 debuggerAttrMap :: B.AttrMap
 debuggerAttrMap =
@@ -66,16 +65,16 @@ darkGreen :: Vty.Color
 darkGreen = Vty.rgbColor @Int 0 100 0
 
 data Options = Options
-    {optUplcPath :: FilePath, optHsPath :: FilePath}
+    { optUplcInput       :: Input
+    , optUplcInputFormat :: Format
+    -- MAYBE: make tx file optional? the sourceeditor should be hidden in that case then
+    , optHsPath          :: FilePath
+    }
 
 parseOptions :: OA.Parser Options
 parseOptions = do
-    optUplcPath <-
-        OA.argument OA.str $
-            mconcat
-                [ OA.metavar "UPLC_FILE"
-                , OA.help "UPLC File"
-                ]
+    optUplcInput <- input
+    optUplcInputFormat <- inputformat
     optHsPath <-
         OA.argument OA.str $
             mconcat
@@ -86,41 +85,15 @@ parseOptions = do
 
 main :: IO ()
 main = do
-    opts <-
+    Options{..} <-
         OA.execParser $
             OA.info
                 (parseOptions OA.<**> OA.helper)
                 (OA.fullDesc <> OA.header "Plutus Core Debugger")
 
-    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)
-    uplcNoAnn <- unDeBruijnProgram uplcDebruijn
-    let uplcText = PLC.displayPlcDef uplcNoAnn
-    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
+    (uplcText, uplcDAnn) <- getTextProgram optUplcInputFormat optUplcInput
 
-    hsText <- Text.readFile (optHsPath opts)
+    hsText <- Text.readFile optHsPath
 
     -- The communication "channels" at debugger-driver and at brick
     driverMailbox <- newEmptyMVar @(D.Cmd Breakpoints)
@@ -153,6 +126,7 @@ main = do
                         EditorSource
                         Nothing
                         hsText
+                , _dsSourceHighlight = Nothing
                 , _dsReturnValueEditor =
                     BE.editorText
                         EditorReturnValue
@@ -172,7 +146,7 @@ main = do
 
     -- TODO: find out if the driver-thread exits when brick exits
     -- or should we wait for driver-thread?
-    _dTid <- forkIO $ driverThread driverMailbox brickMailbox uplc
+    _dTid <- forkIO $ driverThread driverMailbox brickMailbox uplcDAnn
 
     void $ B.customMain initialVty builder (Just brickMailbox) app initialState
 
@@ -207,20 +181,65 @@ driverThread driverMailbox brickMailbox prog = do
         D.StepF prevState k  -> cekMToIO (D.handleStep prevState) >>= k
         D.InputF k           -> handleInput >>= k
         D.LogF text k        -> handleLog text >> k
-        D.UpdateClientF ds k -> handleUpdate ds >> k -- TODO: implement
+        D.UpdateClientF ds k -> handleUpdate ds >> k
       where
         handleInput = takeMVar driverMailbox
         handleUpdate = B.writeBChan brickMailbox . UpdateClientEvent
         handleLog = B.writeBChan brickMailbox . LogEvent
 
-unDeBruijnProgram ::
-    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
+-- | Read uplc code in a given format
+--
+--  Adaptation of `Common.getProgram`
+getTextProgram :: Format -> Input -> IO (Text, UplcProg DAnn)
+getTextProgram fmt inp =
+    case fmt of
+        Textual -> do
+            -- here we use the original raw uplc text, we do not attempt any prettyfying
+            (progTextRaw, uplcPos) <- parseInput inp
+            let progWithUplcSpan = toUplcSpan uplcPos
+                -- IMPORTANT: we cannot have any Tx.SourceSpans available in Textual mode
+                -- We still show the SourceEditor but TX highlighting (or breakpointing) won't work.
+                -- TODO: disable setting TX.breakpoints from inside the brick gui interface
+                addEmptyTxSpans = fmap (`DAnn` mempty)
+                progWithDAnn = addEmptyTxSpans progWithUplcSpan
+            pure (progTextRaw, progWithDAnn)
+
+        Flat flatMode -> do
+            -- here comes the dance of flat-parsing->PRETTYfying->text-parsing
+            -- so we can have artificial SourcePos in annotations
+            progWithTxSpans <- loadASTfromFlat @UplcProg @SrcSpans flatMode inp
+            -- annotations are not pprinted by default, no need to `void`
+            let progTextPretty = PLC.displayPlcDef progWithTxSpans
+
+            -- the parsed prog with megaparsec.sourcepos
+            progWithUplcPos <- either (fail . show @ParserErrorBundle) pure $
+                         runExcept $ PLC.runQuoteT $ UPLC.parseProgram progTextPretty
+
+            -- convert megaparsec.sourcepos to uplc.srcspan
+            let progWithUplcSpan = toUplcSpan progWithUplcPos
+
+            -- zip back the two programs into one program with their annotations' combined
+            -- the zip may fail if the AST cannot parse-pretty roundtrip (should not happen).
+            progWithDAnn <- pzipWith DAnn progWithUplcSpan progWithTxSpans
+
+            pure (progTextPretty, progWithDAnn)
+
+-- | Turn uplc's megaparsec.sourcepos to sourcespans
+toUplcSpan :: UplcProg SourcePos -> UplcProg SrcSpan
+toUplcSpan =
+            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 sp
+                )
+                . zipProgramWithFirstToken
 
 zipProgramWithFirstToken ::
     Program Name uni fun ann ->

plutus-core/executables/debugger/Types.hs

@@ -74,6 +74,7 @@ data DebuggerState = DebuggerState
     , _dsUplcEditor          :: BE.Editor Text ResourceName
     , _dsUplcHighlight       :: Maybe HighlightSpan
     , _dsSourceEditor        :: BE.Editor Text ResourceName
+    , _dsSourceHighlight     :: Maybe HighlightSpan
     , _dsReturnValueEditor   :: BE.Editor Text ResourceName
     , _dsCekStateEditor      :: BE.Editor Text ResourceName
     , _dsVLimitBottomEditors :: Int

plutus-core/executables/src/PlutusCore/Executable/Common.hs

@@ -102,7 +102,7 @@ class ProgramLike p where
     serialiseProgramFlat :: (Flat ann, PP.Pretty ann) => AstNameType -> p ann -> IO BSL.ByteString
 
     -- | Read and deserialise a Flat-encoded AST
-    loadASTfromFlat :: AstNameType -> Input -> IO (p ())
+    loadASTfromFlat :: Flat ann => AstNameType -> Input -> IO (p ann)
 
 -- For PIR and PLC
 serialiseTProgramFlat :: Flat a => AstNameType -> a -> IO BSL.ByteString
@@ -346,7 +346,7 @@ parseInput ::
     -- | The source program
     Input ->
     -- | The output is either a UPLC or PLC program with annotation
-    IO (p PLC.SourcePos)
+    IO (T.Text, p PLC.SourcePos)
 parseInput inp = do
     contents <- getInput inp
     -- parse the program
@@ -364,7 +364,7 @@ parseInput inp = do
                 -- pretty print the error
                 Left (err :: PLC.UniqueError PLC.SourcePos) ->
                     error $ PP.render $ pretty err
-                Right _ -> pure p
+                Right _ -> pure (contents, p)
 
 -- Read a binary-encoded file (eg, Flat-encoded PLC)
 getBinaryInput :: Input -> IO BSL.ByteString
@@ -407,7 +407,7 @@ loadTplcASTfromFlat flatMode inp =
             Right r -> return r
 
 -- | Read and deserialise a Flat-encoded UPLC AST
-loadUplcASTfromFlat :: AstNameType -> Input -> IO (UplcProg ())
+loadUplcASTfromFlat :: Flat ann => AstNameType -> Input -> IO (UplcProg ann)
 loadUplcASTfromFlat flatMode inp = do
     input <- getBinaryInput inp
     case flatMode of
@@ -426,7 +426,7 @@ loadUplcASTfromFlat flatMode inp = do
             Right r -> return r
 
 -- Read either a UPLC/PLC/PIR file or a Flat file, depending on 'fmt'
-getProgram ::
+getProgram :: forall p.
     ( ProgramLike p
     , Functor p
     , PLC.Rename (p PLC.SourcePos)
@@ -436,9 +436,9 @@ getProgram ::
     IO (p PLC.SourcePos)
 getProgram fmt inp =
     case fmt of
-        Textual -> parseInput inp
+        Textual -> snd <$> parseInput inp
         Flat flatMode -> do
-            prog <- loadASTfromFlat flatMode inp
+            prog <- loadASTfromFlat @p @() flatMode inp
             -- No source locations in Flat, so we have to make them up.
             return $ PLC.topSourcePos <$ prog
 
@@ -732,7 +732,7 @@ runPrintBuiltinSignatures = do
 
 runPrint :: PrintOptions -> IO ()
 runPrint (PrintOptions iospec mode) = do
-    parsed <- (parseInput (inputSpec iospec) :: IO (PlcProg PLC.SourcePos))
+    parsed <- (snd <$> parseInput (inputSpec iospec) :: IO (PlcProg PLC.SourcePos))
     let printed = show $ getPrintMethod mode parsed
     case outputSpec iospec of
         FileOutput path -> writeFile path printed

plutus-core/plutus-core.cabal

@@ -184,6 +184,7 @@ library
     UntypedPlutusCore.Check.Uniques
     UntypedPlutusCore.Core
     UntypedPlutusCore.Core.Type
+    UntypedPlutusCore.Core.Zip
     UntypedPlutusCore.DeBruijn
     UntypedPlutusCore.Evaluation.Machine.Cek
     UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts
@@ -647,16 +648,15 @@ executable debugger
   build-depends:
     , base                  >=4.9 && <5
     , brick
-    , bytestring
-    , extra
-    , flat
+    , containers
     , megaparsec
     , microlens
     , microlens-th
     , mono-traversable
     , mtl
     , optparse-applicative
     , plutus-core           ^>=1.1
+    , plutus-core-execlib
     , prettyprinter
     , text
     , vty