Pretty-print UPLC programs with unicode chars (#7242)

Author: zeme-wana

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-03/string-03.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con string "\955-calculus"))
+(program 1.0.0 (con string "λ-calculus"))

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-05/string-05.uplc.expected

@@ -2,6 +2,6 @@
   1.0.0
   (con
     string
-    "x \8712 \8477 \8658 x\178 \8805 0; z \8712 \8450\\\8477 \8658 z\178 \8713 {x \8712 \8477: x \8805 0}."
+    "x ∈ ℝ ⇒ x² ≥ 0; z ∈ ℂ\\ℝ ⇒ z² ∉ {x ∈ ℝ: x ≥ 0}."
   )
 )

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-07/string-07.uplc

@@ -0,0 +1,16 @@
+(program 1.0.0
+	(con (list string)
+    [ "z ∈ ℝ ⇒ x² ≥ 0; z ∈ ℂ"
+    , "x \8712 \8477 \8658 x\178 \8805 0; z \8712 \8450\\\8477 \8658 z\178 \8713 {x \8712 \8477: x \8805 0}." 
+    , "\\"
+    , "\""
+    , "--- \"\"\"\" \\ \\ \\\\ \\\\\\ \""
+    , "\b\n\a\t"
+    , "\DEL"
+    , "€"
+    , "
+"
+    , "	"
+    ]
+    )
+)

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-07/string-07.uplc.budget.expected

@@ -0,0 +1,2 @@
+({cpu: 16100
+| mem: 200})

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-07/string-07.uplc.expected

@@ -0,0 +1,16 @@
+(program
+  1.0.0
+  (con
+    (list string)
+    [ "z ∈ ℝ ⇒ x² ≥ 0; z ∈ ℂ"
+    , "x ∈ ℝ ⇒ x² ≥ 0; z ∈ ℂ\\ℝ ⇒ z² ∉ {x ∈ ℝ: x ≥ 0}."
+    , "\\"
+    , "\""
+    , "--- \"\"\"\" \\ \\ \\\\ \\\\\\ \""
+    , "\b\n\a\t"
+    , "\DEL"
+    , "€"
+    , "\n"
+    , "\t" ]
+  )
+)

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-08/string-08.uplc

@@ -0,0 +1,3 @@
+(program 1.0.0
+	(con string "----- \\" hello"
+))

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-08/string-08.uplc.budget.expected

@@ -0,0 +1 @@
+parse error

plutus-conformance/test-cases/uplc/evaluation/builtin/constant/string/string-08/string-08.uplc.expected

@@ -0,0 +1 @@
+parse error

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

@@ -1,4 +1,7 @@
+{-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
+{-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE RecursiveDo       #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
@@ -11,6 +14,7 @@ import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
 import Control.Monad.State (StateT, evalStateT)
 import Data.Map qualified as M
 import Data.Text (Text)
+import Data.Text qualified as Text
 import Text.Megaparsec hiding (ParseError, State, parse, some)
 import Text.Megaparsec.Char (char, space1)
 import Text.Megaparsec.Char.Lexer qualified as Lex hiding (hexadecimal)
@@ -87,6 +91,69 @@ leadingWhitespace = (whitespace *>)
 trailingWhitespace :: Parser a -> Parser a
 trailingWhitespace = (<* whitespace)
 
+-- This is samething from @Text.Megaparsec.Stream@.
+reachOffsetNoLine' ::
+  forall s.
+  (Stream s) =>
+  -- | How to split input stream at given offset
+  (Int -> s -> (Tokens s, s)) ->
+  -- | How to fold over input stream
+  (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) ->
+  -- | Newline token and tab token
+  (Token s, Token s) ->
+  -- | Offset to reach
+  -- | Increment in column position for a token
+  (Token s -> Pos) ->
+  Int ->
+  -- | Initial 'PosState' to use
+  PosState s ->
+  -- | Updated 'PosState'
+  PosState s
+reachOffsetNoLine'
+  splitAt'
+  foldl''
+  (newlineTok, tabTok)
+  columnIncrement
+  o
+  PosState {..} =
+    ( PosState
+        { pstateInput = post,
+          pstateOffset = max pstateOffset o,
+          pstateSourcePos = spos,
+          pstateTabWidth = pstateTabWidth,
+          pstateLinePrefix = pstateLinePrefix
+        }
+    )
+    where
+      spos = foldl'' go pstateSourcePos pre
+      (pre, post) = splitAt' (o - pstateOffset) pstateInput
+      go (SourcePos n l c) ch =
+        let c' = unPos c
+            w = unPos pstateTabWidth
+         in if
+              | ch == newlineTok ->
+                  SourcePos n (l <> pos1) pos1
+              | ch == tabTok ->
+                  SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))
+              | otherwise ->
+                  SourcePos n l (c <> columnIncrement ch)
+{-# INLINE reachOffsetNoLine' #-}
+
+getSourcePos' :: MonadParsec e Text m => m SourcePos
+getSourcePos' = do
+  st <- getParserState
+  let
+    pst =
+      reachOffsetNoLine'
+        Text.splitAt
+        Text.foldl'
+        ('\n', '\t')
+        (const pos1)
+        (stateOffset st)
+        (statePosState st)
+  setParserState st {statePosState = pst}
+  return (pstateSourcePos pst)
+
 {- | Returns a parser for @a@ by calling the supplied function on the starting
 and ending positions of @a@.
 
@@ -96,15 +163,15 @@ trailing whitespaces.
 -}
 withSpan' :: (SrcSpan -> Parser a) -> Parser a
 withSpan' f = mdo
-  start <- getSourcePos
+  start <- getSourcePos'
   res <- f sp
-  end <- getSourcePos
+  end <- getSourcePos'
   let sp = toSrcSpan start end
   pure res
 
 {- | Like `withSpan'`, but the result parser consumes whitespaces.
 
-@withSpan = (<* whitespace) . withSpan'
+@withSpan = (<* whitespace) . withSpan'@
 -}
 withSpan :: (SrcSpan -> Parser a) -> Parser a
 withSpan = (<* whitespace) . withSpan'

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

@@ -18,6 +18,7 @@ import PlutusCore.Pretty.Readable
 
 import Control.Lens hiding (List)
 import Data.ByteString qualified as BS
+import Data.Char qualified as Char
 import Data.Coerce
 import Data.List.NonEmpty
 import Data.Proxy
@@ -26,7 +27,7 @@ import Data.Typeable
 import Data.Vector.Strict (Vector)
 import Data.Word (Word8)
 import Numeric (showHex)
-import Prettyprinter
+import Prettyprinter as Prettyprinter
 import Prettyprinter.Internal (Doc (Text))
 import Text.PrettyBy
 import Text.PrettyBy.Internal (DefaultPrettyBy (..))
@@ -104,9 +105,19 @@ instance Show a => DefaultPrettyBy ConstConfig (PrettyAny a) where
 prettyConst :: PrettyConst a => RenderContext -> a -> Doc ann
 prettyConst = prettyBy . ConstConfig
 
--- This instance for String quotes control characters (which is what we want)
--- but also Unicode characters (\8704 and so on).
-deriving via PrettyAny T.Text  instance NonDefaultPrettyBy ConstConfig T.Text
+-- This instance for Text quotes control characters (which is what we want)
+-- but doesn't escape Unicode characters (\8704 and so on).
+instance NonDefaultPrettyBy ConstConfig T.Text where
+    nonDefaultPrettyListBy conf = Prettyprinter.list . Prelude.map (nonDefaultPrettyBy conf)
+    nonDefaultPrettyBy = inContextM $ \t -> pure $ pretty $ "\"" <> escape t <> "\""
+        where
+            escape t = T.foldr' prettyChar "" t
+            prettyChar c acc
+                | c == '"' = "\\\"" <> acc -- Not handled by 'showLitChar'
+                | c == '\\' = "\\\\" <> acc -- Not handled by 'showLitChar'
+                | Char.isPrint c = [c] <> acc
+                | otherwise = Char.showLitChar c acc
+
 deriving via PrettyAny ()      instance NonDefaultPrettyBy ConstConfig ()
 deriving via PrettyAny Bool    instance NonDefaultPrettyBy ConstConfig Bool
 deriving via PrettyAny Integer instance NonDefaultPrettyBy ConstConfig Integer