{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module PlutusCore.Pretty.PrettyConst where
import PlutusCore.Data
import PlutusCore.Pretty.Readable
import Control.Lens hiding (List)
import Data.ByteString qualified as BS
import Data.Coerce
import Data.Foldable (fold)
import Data.List.NonEmpty
import Data.Proxy
import Data.Text qualified as T
import Data.Typeable
import Data.Word (Word8)
import Numeric (showHex)
import Prettyprinter
import Prettyprinter.Internal (Doc (Text))
import Text.PrettyBy
import Text.PrettyBy.Internal (DefaultPrettyBy (..))
import Universe
newtype ConstConfig = ConstConfig
{ ConstConfig -> RenderContext
unConstConfig :: RenderContext
}
type instance HasPrettyDefaults ConstConfig = 'False
instance HasRenderContext ConstConfig where
renderContext :: Lens' ConstConfig RenderContext
renderContext = (RenderContext -> f RenderContext) -> ConstConfig -> f ConstConfig
forall s t a b. (Coercible s a, Coercible t b) => Iso s t a b
Iso ConstConfig ConstConfig RenderContext RenderContext
coerced
type PrettyConst = PrettyBy ConstConfig
type PrettyUni uni = (PrettyParens (SomeTypeIn uni), Closed uni, uni `Everywhere` PrettyConst)
type ThrowableBuiltins uni fun = (PrettyUni uni, Pretty fun, Typeable uni, Typeable fun)
instance DefaultPrettyBy ConstConfig (PrettyAny a) => NonDefaultPrettyBy ConstConfig (PrettyAny a)
instance DefaultPrettyBy ConstConfig (PrettyAny a) => PrettyBy ConstConfig (PrettyAny a) where
prettyBy :: forall ann. ConstConfig -> PrettyAny a -> Doc ann
prettyBy = ConstConfig -> PrettyAny a -> Doc ann
forall ann. ConstConfig -> PrettyAny a -> Doc ann
forall config a ann.
DefaultPrettyBy config a =>
config -> a -> Doc ann
defaultPrettyBy
prettyListBy :: forall ann. ConstConfig -> [PrettyAny a] -> Doc ann
prettyListBy = ConstConfig -> [PrettyAny a] -> Doc ann
forall ann. ConstConfig -> [PrettyAny a] -> Doc ann
forall config a ann.
DefaultPrettyBy config a =>
config -> [a] -> Doc ann
defaultPrettyListBy
instance Show a => DefaultPrettyBy ConstConfig (PrettyAny a) where
defaultPrettyBy :: forall ann. ConstConfig -> PrettyAny a -> Doc ann
defaultPrettyBy ConstConfig
_ = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (PrettyAny a -> String) -> PrettyAny a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @a (a -> String) -> (PrettyAny a -> a) -> PrettyAny a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyAny a -> a
forall a b. Coercible a b => a -> b
coerce
defaultPrettyListBy :: forall ann. ConstConfig -> [PrettyAny a] -> Doc ann
defaultPrettyListBy ConstConfig
_ = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> ([PrettyAny a] -> String) -> [PrettyAny a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @[a] ([a] -> String)
-> ([PrettyAny a] -> [a]) -> [PrettyAny a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PrettyAny a] -> [a]
forall a b. Coercible a b => a -> b
coerce
prettyConst :: PrettyConst a => RenderContext -> a -> Doc ann
prettyConst :: forall a ann. PrettyConst a => RenderContext -> a -> Doc ann
prettyConst = ConstConfig -> a -> Doc ann
forall ann. ConstConfig -> a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy (ConstConfig -> a -> Doc ann)
-> (RenderContext -> ConstConfig) -> RenderContext -> a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderContext -> ConstConfig
ConstConfig
deriving via PrettyAny T.Text instance NonDefaultPrettyBy ConstConfig T.Text
deriving via PrettyAny () instance NonDefaultPrettyBy ConstConfig ()
deriving via PrettyAny Bool instance NonDefaultPrettyBy ConstConfig Bool
deriving via PrettyAny Integer instance NonDefaultPrettyBy ConstConfig Integer
newtype NoParens a = NoParens
{ forall a. NoParens a -> a
unNoParens :: a
}
instance PrettyConst a => PrettyBy ConstConfig (NoParens a) where
prettyBy :: forall ann. ConstConfig -> NoParens a -> Doc ann
prettyBy ConstConfig
config = forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy @_ @a (ConstConfig
config ConstConfig -> (ConstConfig -> ConstConfig) -> ConstConfig
forall a b. a -> (a -> b) -> b
& (RenderContext -> Identity RenderContext)
-> ConstConfig -> Identity ConstConfig
forall config.
HasRenderContext config =>
Lens' config RenderContext
Lens' ConstConfig RenderContext
renderContext ((RenderContext -> Identity RenderContext)
-> ConstConfig -> Identity ConstConfig)
-> RenderContext -> ConstConfig -> ConstConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RenderContext
botRenderContext) (a -> Doc ann) -> (NoParens a -> a) -> NoParens a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoParens a -> a
forall a b. Coercible a b => a -> b
coerce
prettyListBy :: forall ann. ConstConfig -> [NoParens a] -> Doc ann
prettyListBy ConstConfig
config = forall config a ann. PrettyBy config a => config -> [a] -> Doc ann
prettyListBy @_ @a (ConstConfig
config ConstConfig -> (ConstConfig -> ConstConfig) -> ConstConfig
forall a b. a -> (a -> b) -> b
& (RenderContext -> Identity RenderContext)
-> ConstConfig -> Identity ConstConfig
forall config.
HasRenderContext config =>
Lens' config RenderContext
Lens' ConstConfig RenderContext
renderContext ((RenderContext -> Identity RenderContext)
-> ConstConfig -> Identity ConstConfig)
-> RenderContext -> ConstConfig -> ConstConfig
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RenderContext
botRenderContext) ([a] -> Doc ann)
-> ([NoParens a] -> [a]) -> [NoParens a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NoParens a] -> [a]
forall a b. Coercible a b => a -> b
coerce
instance PrettyConst a => NonDefaultPrettyBy ConstConfig [a] where
nonDefaultPrettyBy :: forall ann. ConstConfig -> [a] -> Doc ann
nonDefaultPrettyBy ConstConfig
config = forall config a ann.
DefaultPrettyBy config a =>
config -> a -> Doc ann
defaultPrettyBy @_ @[NoParens a] ConstConfig
config ([NoParens a] -> Doc ann)
-> ([a] -> [NoParens a]) -> [a] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [NoParens a]
forall a b. Coercible a b => a -> b
coerce
instance (PrettyConst a, PrettyConst b) => NonDefaultPrettyBy ConstConfig (a, b) where
nonDefaultPrettyBy :: forall ann. ConstConfig -> (a, b) -> Doc ann
nonDefaultPrettyBy ConstConfig
config = forall config a ann.
DefaultPrettyBy config a =>
config -> a -> Doc ann
defaultPrettyBy @_ @(NoParens a, NoParens b) ConstConfig
config ((NoParens a, NoParens b) -> Doc ann)
-> ((a, b) -> (NoParens a, NoParens b)) -> (a, b) -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> (NoParens a, NoParens b)
forall a b. Coercible a b => a -> b
coerce
asBytes :: Word8 -> Doc ann
asBytes :: forall ann. Word8 -> Doc ann
asBytes Word8
x = Int -> Text -> Doc ann
forall ann. Int -> Text -> Doc ann
Text Int
2 (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
addLeadingZero (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Word8 -> String -> String
forall a. Integral a => a -> String -> String
showHex Word8
x String
forall a. Monoid a => a
mempty
where addLeadingZero :: String -> String
addLeadingZero :: String -> String
addLeadingZero
| Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
16 = (Char
'0' Char -> String -> String
forall a. a -> [a] -> [a]
:)
| Bool
otherwise = String -> String
forall a. a -> a
id
toBytes :: BS.ByteString -> Doc ann
toBytes :: forall ann. ByteString -> Doc ann
toBytes ByteString
b = [Doc ann] -> Doc ann
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Word8 -> Doc ann
forall ann. Word8 -> Doc ann
asBytes (Word8 -> Doc ann) -> [Word8] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [Word8]
BS.unpack ByteString
b)
instance PrettyBy ConstConfig Data where
prettyBy :: forall ann. ConstConfig -> Data -> Doc ann
prettyBy = (Data -> InContextM ConstConfig (Doc ann))
-> ConstConfig -> Data -> Doc ann
forall a config ann.
(a -> InContextM config (Doc ann)) -> config -> a -> Doc ann
inContextM ((Data -> InContextM ConstConfig (Doc ann))
-> ConstConfig -> Data -> Doc ann)
-> (Data -> InContextM ConstConfig (Doc ann))
-> ConstConfig
-> Data
-> Doc ann
forall a b. (a -> b) -> a -> b
$ \Data
d0 -> (AnyToDoc ConstConfig ann
-> AnyToDoc ConstConfig ann -> NonEmpty (Doc ann))
-> InContextM ConstConfig (Doc ann)
forall config env (m :: * -> *) ann.
MonadPrettyContext config env m =>
(AnyToDoc config ann -> AnyToDoc config ann -> NonEmpty (Doc ann))
-> m (Doc ann)
iterAppDocM ((AnyToDoc ConstConfig ann
-> AnyToDoc ConstConfig ann -> NonEmpty (Doc ann))
-> InContextM ConstConfig (Doc ann))
-> (AnyToDoc ConstConfig ann
-> AnyToDoc ConstConfig ann -> NonEmpty (Doc ann))
-> InContextM ConstConfig (Doc ann)
forall a b. (a -> b) -> a -> b
$ \AnyToDoc ConstConfig ann
_ AnyToDoc ConstConfig ann
prettyArg -> case Data
d0 of
Constr Integer
i [Data]
ds -> (Doc ann
"Constr" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
AnyToDoc ConstConfig ann
prettyArg Integer
i) Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [[Data] -> Doc ann
AnyToDoc ConstConfig ann
prettyArg [Data]
ds]
Map [(Data, Data)]
ps -> Doc ann
"Map" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [[(Data, Data)] -> Doc ann
AnyToDoc ConstConfig ann
prettyArg [(Data, Data)]
ps]
List [Data]
ds -> Doc ann
"List" Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| [[Data] -> Doc ann
AnyToDoc ConstConfig ann
prettyArg [Data]
ds]
I Integer
i -> (Doc ann
"I" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Integer -> Doc ann
AnyToDoc ConstConfig ann
prettyArg Integer
i) Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| []
B ByteString
b -> (Doc ann
"B" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ByteString -> Doc ann
AnyToDoc ConstConfig ann
prettyArg ByteString
b) Doc ann -> [Doc ann] -> NonEmpty (Doc ann)
forall a. a -> [a] -> NonEmpty a
:| []
instance PrettyBy ConstConfig BS.ByteString where
prettyBy :: forall ann. ConstConfig -> ByteString -> Doc ann
prettyBy ConstConfig
_ ByteString
b = Doc ann
"#" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc ann
forall ann. ByteString -> Doc ann
toBytes ByteString
b
instance Pretty (SomeTypeIn uni) => Pretty (SomeTypeIn (Kinded uni)) where
pretty :: forall ann. SomeTypeIn (Kinded uni) -> Doc ann
pretty (SomeTypeIn (Kinded uni (Esc a)
uni)) = SomeTypeIn uni -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. SomeTypeIn uni -> Doc ann
pretty (uni (Esc a) -> SomeTypeIn uni
forall (uni :: * -> *) k (a :: k). uni (Esc a) -> SomeTypeIn uni
SomeTypeIn uni (Esc a)
uni)
instance (Closed uni, uni `Everywhere` PrettyConst) => PrettyBy ConstConfig (ValueOf uni a) where
prettyBy :: forall ann. ConstConfig -> ValueOf uni a -> Doc ann
prettyBy ConstConfig
config (ValueOf uni (Esc a)
uni a
x) = Proxy PrettyConst
-> uni (Esc a) -> (PrettyConst a => Doc ann) -> Doc ann
forall (uni :: * -> *) (constr :: * -> Constraint)
(proxy :: (* -> Constraint) -> *) a r.
(Closed uni, Everywhere uni constr) =>
proxy constr -> uni (Esc a) -> (constr a => r) -> r
forall (constr :: * -> Constraint)
(proxy :: (* -> Constraint) -> *) a r.
Everywhere uni constr =>
proxy constr -> uni (Esc a) -> (constr a => r) -> r
bring (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @PrettyConst) uni (Esc a)
uni ((PrettyConst a => Doc ann) -> Doc ann)
-> (PrettyConst a => Doc ann) -> Doc ann
forall a b. (a -> b) -> a -> b
$ ConstConfig -> a -> Doc ann
forall ann. ConstConfig -> a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy ConstConfig
config a
x
instance (Closed uni, uni `Everywhere` PrettyConst) =>
PrettyBy ConstConfig (Some (ValueOf uni)) where
prettyBy :: forall ann. ConstConfig -> Some (ValueOf uni) -> Doc ann
prettyBy ConstConfig
config (Some ValueOf uni a
s) = ConstConfig -> ValueOf uni a -> Doc ann
forall ann. ConstConfig -> ValueOf uni a -> Doc ann
forall config a ann. PrettyBy config a => config -> a -> Doc ann
prettyBy ConstConfig
config ValueOf uni a
s
instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (ValueOf uni a) where
pretty :: forall ann. ValueOf uni a -> Doc ann
pretty = RenderContext -> ValueOf uni a -> Doc ann
forall a ann. PrettyConst a => RenderContext -> a -> Doc ann
prettyConst RenderContext
juxtRenderContext
instance (Closed uni, uni `Everywhere` PrettyConst) => Pretty (Some (ValueOf uni)) where
pretty :: forall ann. Some (ValueOf uni) -> Doc ann
pretty = RenderContext -> Some (ValueOf uni) -> Doc ann
forall a ann. PrettyConst a => RenderContext -> a -> Doc ann
prettyConst RenderContext
juxtRenderContext