Use SrcSpan in UPLC parser (#5119)

plutus-conformance/plutus-conformance.cabal

@@ -50,7 +50,6 @@ library
     , directory
     , filepath
     , lens
-    , megaparsec
     , plutus-core             ^>=1.1
     , plutus-metatheory
     , tasty

plutus-conformance/src/PlutusConformance/Common.hs

@@ -10,6 +10,7 @@ import Control.Monad.Trans.Except
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import MAlonzo.Code.Main (runUAgda)
+import PlutusCore.Annotation
 import PlutusCore.Default (DefaultFun, DefaultUni)
 import PlutusCore.Error (Error (..), ParserErrorBundle)
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters)
@@ -23,7 +24,6 @@ import Test.Tasty.ExpectedFailure (expectFail)
 import Test.Tasty.Golden (findByExtension)
 import Test.Tasty.Golden.Advanced (goldenTest)
 import Test.Tasty.Providers (TestTree)
-import Text.Megaparsec (SourcePos)
 import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.DeBruijn
 import UntypedPlutusCore.Evaluation.Machine.Cek (evaluateCekNoEmit)
@@ -45,7 +45,7 @@ shownEvaluationFailure = "evaluation failure"
 -- | The default parser to parse UPLC program inputs.
 parseTxt ::
     T.Text
-    -> Either ParserErrorBundle (UPLC.Program Name DefaultUni DefaultFun SourcePos)
+    -> Either ParserErrorBundle (UPLC.Program Name DefaultUni DefaultFun SrcSpan)
 parseTxt resTxt = runQuoteT $ UPLC.parseProgram resTxt
 
 -- | The input/output UPLC program type.
@@ -241,4 +241,3 @@ agdaEvalUplcProgDebug (UPLC.Program () version tmU) =
                                 "The input to runUAgda was " <> show tmUDBSuccess <>
                                 ", returned by deBruijnTerm."
                         Right namedTerm -> Right $ UPLC.Program () version namedTerm
-

plutus-core/executables/debugger/Event.hs

@@ -81,7 +81,10 @@ handleDebuggerEvent _driverMailbox (B.AppEvent (UpdateClientEvent cekState)) = d
                 _                 -> Nothing
             pure HighlightSpan
                 { _hcSLoc = B.Location (srcSpanSLine uplcSpan, srcSpanSCol uplcSpan),
-                  _hcELoc = Just $ B.Location (srcSpanELine uplcSpan, srcSpanECol uplcSpan)
+                  -- The ending column of a `SrcSpan` is usually one more than the column of
+                  -- the last character (same as GHC's `SrcSpan`), unless the last character
+                  -- is the line break, hence the `- 1`.
+                  _hcELoc = Just $ B.Location (srcSpanELine uplcSpan, srcSpanECol uplcSpan - 1)
                 }
     modify' $ \st -> case cekState of
         Computing{} ->

plutus-core/executables/debugger/Main.hs

@@ -17,7 +17,6 @@
 module Main (main) where
 
 import PlutusCore qualified as PLC
-import PlutusCore.Annotation
 import PlutusCore.Error
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
 import PlutusCore.Evaluation.Machine.MachineParameters
@@ -42,15 +41,12 @@ 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 =
@@ -103,23 +99,10 @@ main = do
     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
-
+        either (error . PLC.display @_ @ParserErrorBundle) pure
+            . PLC.runQuoteT
+            $ UPLC.parseProgram uplcText
+    let uplc = fmap (\sp -> DAnn sp mempty) uplcParsed
     hsText <- Text.readFile (optHsPath opts)
 
     -- The communication "channels" at debugger-driver and at brick
@@ -221,28 +204,3 @@ unDeBruijnProgram p = do
         . 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/src/PlutusCore/Executable/Common.hs

@@ -35,7 +35,7 @@ import PlutusCore.StdLib.Data.Unit qualified as StdLib
 import UntypedPlutusCore qualified as UPLC
 import UntypedPlutusCore.Check.Uniques qualified as UPLC (checkProgram)
 import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek
-import UntypedPlutusCore.Parser qualified as UPLC (parse, program)
+import UntypedPlutusCore.Parser qualified as UPLC (parse, program, spanToPos)
 
 import PlutusIR.Core.Type qualified as PIR
 import PlutusIR.Parser qualified as PIR (parse, program)
@@ -128,7 +128,8 @@ instance ProgramLike PlcProg where
 
 -- | Instance for UPLC program.
 instance ProgramLike UplcProg where
-    parseNamedProgram inputName = PLC.runQuoteT . UPLC.parse UPLC.program inputName
+    parseNamedProgram inputName =
+        fmap (fmap UPLC.spanToPos) . PLC.runQuoteT . UPLC.parse UPLC.program inputName
     checkUniques = UPLC.checkProgram (const True)
     serialiseProgramFlat nameType p =
         case nameType of

plutus-core/plutus-core/src/PlutusCore.hs

@@ -10,6 +10,7 @@ module PlutusCore
     , parseType
     , SourcePos
     , topSourcePos
+    , SrcSpan (..)
     -- * Builtins
     , Some (..)
     , SomeTypeIn (..)
@@ -122,6 +123,7 @@ module PlutusCore
     ) where
 
 
+import PlutusCore.Annotation
 import PlutusCore.Builtin
 import PlutusCore.Core
 import PlutusCore.DeBruijn

plutus-core/plutus-core/src/PlutusCore/Annotation.hs

@@ -76,6 +76,9 @@ data SrcSpan = SrcSpan
     , srcSpanSCol  :: Int
     , srcSpanELine :: Int
     , srcSpanECol  :: Int
+    -- ^ Same as GHC's @SrcSpan@, @srcSpanECol@ is usually one more than the column of
+    -- the last character of the thing this @SrcSpan@ is for (unless the last character
+    -- is the line break).
     }
     deriving stock (Eq, Ord, Generic)
     deriving anyclass (Flat)
@@ -90,7 +93,7 @@ instance Show SrcSpan where
             . showChar '-'
             . showsPrec 0 (srcSpanELine s)
             . showChar ':'
-            . showsPrec 0 (srcSpanECol s)
+            . showsPrec 0 (if srcSpanECol s == 0 then 0 else srcSpanECol s - 1)
 
 instance Pretty SrcSpan where
     pretty = viaShow

plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs

@@ -1,21 +1,22 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecursiveDo       #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Common functions for parsers of UPLC, PLC, and PIR.
 
 module PlutusCore.Parser.ParserCommon where
 
+import Control.Monad.Except
+import Control.Monad.State (MonadState (get, put), StateT, evalStateT)
 import Data.Char (isAlphaNum)
 import Data.Map qualified as M
 import Data.Text qualified as T
-import PlutusPrelude
 import Text.Megaparsec hiding (ParseError, State, parse, some)
 import Text.Megaparsec.Char (char, letterChar, space1)
 import Text.Megaparsec.Char.Lexer qualified as Lex hiding (hexadecimal)
 
-import Control.Monad.Except
-import Control.Monad.State (MonadState (get, put), StateT, evalStateT)
+import PlutusCore.Annotation
 import PlutusCore.Core.Type
 import PlutusCore.Error
 import PlutusCore.Name
@@ -74,6 +75,26 @@ parseGen stuff = parse stuff "test"
 whitespace :: Parser ()
 whitespace = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockCommentNested "{-" "-}")
 
+-- | Returns a parser for @a@ by calling the supplied function on the starting
+-- and ending positions of @a@.
+--
+-- The supplied function should usually return a parser that does /not/ consume trailing
+-- whitespaces. Otherwise, the end position will be the first character after the
+-- trailing whitespaces.
+withSpan' :: (SrcSpan -> Parser a) -> Parser a
+withSpan' f = mdo
+  start <- getSourcePos
+  res <- f sp
+  end <- getSourcePos
+  let sp = toSrcSpan start end
+  pure res
+
+-- | Like `withSpan'`, but the result parser consumes whitespaces.
+--
+-- @withSpan = (<* whitespace) . withSpan'
+withSpan :: (SrcSpan -> Parser a) -> Parser a
+withSpan = (<* whitespace) . withSpan'
+
 lexeme :: Parser a -> Parser a
 lexeme = Lex.lexeme whitespace
 
@@ -83,12 +104,26 @@ symbol = Lex.symbol whitespace
 inParens :: Parser a -> Parser a
 inParens = between (symbol "(") (symbol ")")
 
+-- | Like `inParens` but does not consume trailing whitespaces.
+-- The other ticked functions below are similar.
+--
+-- TODO: these ticked functions should replace the original ones once PIR and TPLC parsers
+-- are migrated to `SrcSpan`.
+inParens' :: Parser a -> Parser a
+inParens' = between (symbol "(") (char ')')
+
 inBrackets :: Parser a -> Parser a
 inBrackets = between (symbol "[") (symbol "]")
 
-inBraces :: Parser a-> Parser a
+inBrackets' :: Parser a -> Parser a
+inBrackets' = between (symbol "[") (char ']')
+
+inBraces :: Parser a -> Parser a
 inBraces = between (symbol "{") (symbol "}")
 
+inBraces' :: Parser a -> Parser a
+inBraces' = between (symbol "{") (char '}')
+
 isIdentifierChar :: Char -> Bool
 isIdentifierChar c = isAlphaNum c || c == '_' || c == '\''
 
@@ -99,6 +134,16 @@ wordPos ::
     T.Text -> Parser SourcePos
 wordPos w = lexeme $ try $ getSourcePos <* symbol w
 
+toSrcSpan :: SourcePos -> SourcePos -> SrcSpan
+toSrcSpan start end =
+    SrcSpan
+        { srcSpanFile = sourceName start
+        , srcSpanSLine = unPos (sourceLine start)
+        , srcSpanSCol = unPos (sourceColumn start)
+        , srcSpanELine = unPos (sourceLine end)
+        , srcSpanECol = unPos (sourceColumn end)
+        }
+
 version :: Parser (Version SourcePos)
 version = lexeme $ do
     p <- getSourcePos
@@ -108,6 +153,14 @@ version = lexeme $ do
     void $ char '.'
     Version p x y <$> Lex.decimal
 
+version' :: Parser (Version SrcSpan)
+version' = withSpan $ \sp -> do
+    x <- Lex.decimal
+    void $ char '.'
+    y <- Lex.decimal
+    void $ char '.'
+    Version sp x y <$> Lex.decimal
+
 name :: Parser Name
 name = lexeme $ try $ do
     void $ lookAhead letterChar

plutus-core/plutus-core/src/PlutusCore/Quote.hs

@@ -1,4 +1,3 @@
--- editorconfig-checker-disable-file
 {-# LANGUAGE DefaultSignatures     #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -46,10 +45,21 @@ type FreshState = Unique
 emptyFreshState :: FreshState
 emptyFreshState = Unique 0
 
--- | The "quotation" monad transformer. Within this monad you can do safe construction of PLC terms using quasiquotation,
--- fresh-name generation, and parsing.
-newtype QuoteT m a = QuoteT { unQuoteT :: StateT FreshState m a }
-    deriving newtype (Functor, Applicative, Monad, MonadTrans, MM.MFunctor, MonadError e, MonadReader r, MonadIO, MonadWriter w)
+-- | The "quotation" monad transformer. Within this monad you can do safe construction of PLC
+-- terms using quasiquotation, fresh-name generation, and parsing.
+newtype QuoteT m a = QuoteT {unQuoteT :: StateT FreshState m a}
+    deriving newtype
+        ( Functor
+        , Applicative
+        , Monad
+        , MonadTrans
+        , MonadFix
+        , MM.MFunctor
+        , MonadError e
+        , MonadReader r
+        , MonadIO
+        , MonadWriter w
+        )
 
 -- Need to write this by hand, deriving wants to derive the one for DefState
 instance MonadState s m => MonadState s (QuoteT m) where
@@ -60,8 +70,9 @@ instance MonadState s m => MonadState s (QuoteT m) where
 -- | A monad that allows lifting of quoted expressions.
 class Monad m => MonadQuote m where
     liftQuote :: Quote a -> m a
-    -- This means we don't have to implement it when we're writing an instance for a MonadTrans monad. We can't just
-    -- add an instance declaration for that, because it overlaps with the base instance.
+    -- This means we don't have to implement it when we're writing an instance for a MonadTrans
+    -- monad. We can't just add an instance declaration for that, because it overlaps with the
+    -- base instance.
     default liftQuote :: (MonadQuote n, MonadTrans t, t n ~ m) => Quote a -> m a
     liftQuote = lift . liftQuote
 
@@ -110,11 +121,13 @@ freshTyName = fmap TyName <$> freshName
 freshenTyName :: MonadQuote m => TyName -> m TyName
 freshenTyName (TyName name) = TyName <$> freshenName name
 
--- | Mark all 'Unique's less than the given 'Unique' as used, so they will not be generated in future.
+-- | Mark all 'Unique's less than the given 'Unique' as used, so they will not be generated
+-- in future.
 markNonFreshBelow :: MonadQuote m => Unique -> m ()
 markNonFreshBelow = liftQuote . QuoteT . modify . max
 
--- | Mark a given 'Unique' (and implicitly all 'Unique's less than it) as used, so they will not be generated in future.
+-- | Mark a given 'Unique' (and implicitly all 'Unique's less than it) as used, so they will
+-- not be generated in future.
 markNonFresh :: MonadQuote m => Unique -> m ()
 markNonFresh = markNonFreshBelow . succ