wip

plutus-core/executables/debugger/Event.hs

@@ -17,11 +17,11 @@ 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
-import Data.Set as S
-import Data.Coerce
 
 handleDebuggerEvent :: MVar (D.Cmd Breakpoints)
                     -> B.BrickEvent ResourceName CustomBrickEvent

plutus-core/executables/debugger/Main.hs

@@ -21,13 +21,13 @@ 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
 import UntypedPlutusCore.Evaluation.Machine.Cek.Debug.Internal
 import UntypedPlutusCore.Parser qualified as UPLC
-import PlutusCore.Executable.Common
-import PlutusCore.Executable.Parsers
 
 import Draw
 import Event
@@ -49,6 +49,7 @@ import Graphics.Vty qualified as Vty
 import Lens.Micro
 import Options.Applicative qualified as OA
 import Text.Megaparsec (unPos)
+import UntypedPlutusCore.Core.Zip
 
 debuggerAttrMap :: B.AttrMap
 debuggerAttrMap =
@@ -64,9 +65,9 @@ darkGreen :: Vty.Color
 darkGreen = Vty.rgbColor @Int 0 100 0
 
 data Options = Options
-    { optUplcInput :: Input
+    { optUplcInput       :: Input
     , optUplcInputFormat :: Format
-    , optHsPath :: FilePath
+    , optHsPath          :: FilePath
     }
 
 parseOptions :: OA.Parser Options
@@ -89,36 +90,7 @@ main = do
                 (parseOptions OA.<**> OA.helper)
                 (OA.fullDesc <> OA.header "Plutus Core Debugger")
 
-    -- unlessM (doesFileExist optUplcInput) . fail $
-    --     "Does not exist or not a file: " <> optUplcPath
-    -- uplcFlat <- Lazy.readFile optUplcPath
-    -- 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
-
-    (uplcText, uplcPos) <- getTextProgram optUplcInputFormat optUplcInput
-
-    let uplcDann =
-            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 uplcPos
+    (uplcText, uplcDann) <- getTextProgram optUplcInputFormat optUplcInput
 
     hsText <- Text.readFile optHsPath
 
@@ -240,17 +212,47 @@ zipTermWithFirstToken = go
         Error ann            -> Error (ann, "error")
 
 -- | Adaptation of `Common.getProgram`
-getTextProgram :: Format -> Input -> IO (Text, UplcProg SourcePos)
-getTextProgram fmt inp = do
+getTextProgram :: Format -> Input -> IO (Text, UplcProg DAnn)
+getTextProgram fmt inp =
     case fmt of
-        Textual ->
+        Textual -> do
             -- here we use the original sourcepos, we do not attempt any prettyfying
-            parseInput inp
+            (uplcText, uplcPos) <- parseInput inp
+            let progUplcSpan = toUplcSpan uplcPos
+                addEmptyTxSpans = fmap (flip DAnn mempty)
+                uplcDAnn = addEmptyTxSpans progUplcSpan
+            -- TODO: disable the ability to set tx breakpoints&highlight in case of textual input
+            pure (uplcText, uplcDAnn)
+
         Flat flatMode -> do
             -- here comes the dance of flat-parsing->prettyfying->text-parsing
             -- so we can have artificial SourcePos in annotations
-            progNoAnn <- loadASTfromFlat @UplcProg flatMode inp
-            let progPretty = PLC.displayPlcDef progNoAnn
+            progTxSpans <- loadASTfromFlat @UplcProg @SrcSpans flatMode inp
+            let progPretty = PLC.displayPlcDef $
+                                  -- do not dump the tx spans
+                                  void progTxSpans
             progPos <- either (error . show @ParserErrorBundle) pure $
                          runExcept $ PLC.runQuoteT $ UPLC.parseProgram progPretty
-            pure (progPretty, progPos)
+            let uplcSpan = toUplcSpan progPos
+
+            progDAnn <- pzipWith DAnn uplcSpan progTxSpans
+
+            pure (progPretty, progDAnn)
+
+
+
+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

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
@@ -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)
@@ -438,7 +438,7 @@ getProgram fmt inp =
     case fmt of
         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
 

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
@@ -264,7 +265,6 @@ library
     UntypedPlutusCore.Core.Instance.Pretty.Readable
     UntypedPlutusCore.Core.Instance.Recursive
     UntypedPlutusCore.Core.Plated
-    UntypedPlutusCore.Core.Zip
     UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode
     UntypedPlutusCore.Evaluation.Machine.Cek.ExBudgetMode
     UntypedPlutusCore.Mark
@@ -648,18 +648,18 @@ executable debugger
   build-depends:
     , base                  >=4.9 && <5
     , brick
+    , containers
     , megaparsec
     , microlens
     , microlens-th
     , mono-traversable
     , mtl
     , optparse-applicative
     , plutus-core           ^>=1.1
+    , plutus-core-execlib
     , prettyprinter
     , text
     , vty
-    , containers
-    , plutus-core-execlib
 
 -- Tests for functions called by @traceToStacks@.
 test-suite traceToStacks-test

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

@@ -50,6 +50,10 @@ module PlutusCore.Core.Type
     , progAnn
     , progVer
     , progTerm
+    , verAnn
+    , verMajor
+    , verMinor
+    , verPatch
     )
 where
 
@@ -141,10 +145,15 @@ Compatibility is about compatibility for specific scripts, not about e.g. tools
 Adding a new kind of term does not change how existing scripts behave, but does change what
 tools would need to do to process scripts.
 -}
-data Version ann
-    = Version ann Natural Natural Natural
+data Version ann = Version
+    { _verAnn   :: ann
+    , _verMajor :: Natural
+    , _verMinor :: Natural
+    , _verPatch :: Natural
+    }
     deriving stock (Eq, Show, Functor, Generic)
     deriving anyclass (NFData, Hashable)
+makeLenses ''Version
 
 -- | A 'Program' is simply a 'Term' coupled with a 'Version' of the core language.
 data Program tyname name uni fun ann = Program

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs

@@ -10,6 +10,9 @@
 module UntypedPlutusCore.Core.Type
     ( TPLC.UniOf
     , TPLC.Version (..)
+    , TPLC.verAnn
+    , TPLC.verMajor
+    , TPLC.verMinor
     , TPLC.Binder (..)
     , Term (..)
     , Program (..)

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Zip.hs

@@ -1,14 +1,33 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies        #-}
 module UntypedPlutusCore.Core.Zip
-    ( tzipWith
+    (
+      pzipWith
+    , pzip
+    , tzipWith
     , tzip
     ) where
 
 import Control.Monad (when)
 import PlutusPrelude
-import UntypedPlutusCore.Core.Type
 import UntypedPlutusCore.Core.Instance.Eq ()
+import UntypedPlutusCore.Core.Type
+
+-- | Zip two programa using a combinator function for annotations.
+-- Fail if the input programs are not "equal" modulo annotations.
+pzipWith :: forall p name uni fun ann1 ann2 ann3 m.
+           (p ~ Program name uni fun, (Eq (Term name uni fun ())), MonadFail m)
+         => (ann1 -> ann2 -> ann3)
+         -> p ann1
+         -> p ann2
+         -> m (p ann3)
+pzipWith f (Program ann1 ver1 t1) (Program ann2 ver2 t2) = do
+    when (void ver1 /= void ver2) $
+       fail "Versions do not match."
+    let ver1Combined = over verAnn (`f` (ver2^.verAnn)) ver1
+    Program (f ann1 ann2) ver1Combined <$> tzipWith f t1 t2
+
+
 
 -- | Zip two terms using a combinator function for annotations.
 -- Fail if the input terms are not "equal" modulo annotations.
@@ -28,17 +47,23 @@ tzipWith f term1 term2 = do
  where
    go :: t ann1 -> t ann2 -> m (t ann3)
    -- MAYBE: some boilerplate could be removed on the following clauses if termAnn was a lens
-   go (Constant a1 s1) (Constant a2 _s2) = pure $ Constant (f a1 a2) s1
-   go (Builtin a1 f1) (Builtin a2 _f2) = pure $ Builtin (f a1 a2) f1
-   go (Var a1 n1) (Var a2 _n2) = pure $ Var (f a1 a2) n1
-   go (Error a1) (Error a2) = pure $ Error (f a1 a2)
+   go (Constant a1 s1) (Constant a2 _s2)    = pure $ Constant (f a1 a2) s1
+   go (Builtin a1 f1) (Builtin a2 _f2)      = pure $ Builtin (f a1 a2) f1
+   go (Var a1 n1) (Var a2 _n2)              = pure $ Var (f a1 a2) n1
+   go (Error a1) (Error a2)                 = pure $ Error (f a1 a2)
    -- MAYBE: some boilerplate could be removed here if we used parallel subterm traversals/toListOf
-   go (LamAbs a1 n1 t1) (LamAbs a2 _n2 t2) = LamAbs (f a1 a2) n1 <$> go t1 t2
+   go (LamAbs a1 n1 t1) (LamAbs a2 _n2 t2)  = LamAbs (f a1 a2) n1 <$> go t1 t2
    go (Apply a1 t1a t1b) (Apply a2 t2a t2b) = Apply (f a1 a2) <$> go t1a t2a <*> go t1b t2b
-   go (Force a1 t1) (Force a2 t2)  = Force (f a1 a2) <$> go t1 t2
-   go (Delay a1 t1) (Delay a2 t2) = Delay (f a1 a2) <$> go t1 t2
-   go _ _ = fail "This should not happen, because we prior established term equality."
+   go (Force a1 t1) (Force a2 t2)           = Force (f a1 a2) <$> go t1 t2
+   go (Delay a1 t1) (Delay a2 t2)           = Delay (f a1 a2) <$> go t1 t2
+   go _ _                                   = fail "This should not happen, because we prior established term equality."
+
 
+pzip :: (p ~ Program name uni fun, Eq (Term name uni fun ()), MonadFail m)
+    => p ann1
+    -> p ann2
+    -> m (p (ann1,ann2))
+pzip = pzipWith (,)
 
 tzip :: (t ~ Term name uni fun, Eq (t ()), MonadFail m)
     => t ann1