From 10011f05ade6d8e1e3ebe354201870f364948d84 Mon Sep 17 00:00:00 2001 From: Evgenii Akentev Date: Wed, 26 May 2021 16:58:23 +0500 Subject: [PATCH] Add opaque ByteString type to support literal ByteStrings. --- plutus-ledger-api/src/Plutus/V1/Ledger/Ada.hs | 5 +- .../src/Plutus/V1/Ledger/Bytes.hs | 5 +- .../src/Plutus/V1/Ledger/Credential.hs | 3 +- .../src/Plutus/V1/Ledger/Crypto.hs | 5 +- .../src/Plutus/V1/Ledger/Scripts.hs | 14 +- .../src/Plutus/V1/Ledger/Value.hs | 13 +- .../src/PlutusTx/Compiler/Expr.hs | 14 +- plutus-tx-plugin/test/Lift/Spec.hs | 4 - plutus-tx-plugin/test/Plugin/Errors/Spec.hs | 6 +- .../Plugin/Errors/literalCaseBs.plc.golden | 1 - .../Errors/literalConcatenateBs.plc.golden | 3 + .../test/Plugin/Primitives/Spec.hs | 31 +++-- .../Plugin/Primitives/decodeUtf8.plc.golden | 2 +- .../Primitives/emptyByteString.plc.golden | 69 +++++++++- .../Primitives/equalsByteString.plc.golden | 41 +++++- .../Plugin/Primitives/ltByteString.plc.golden | 41 +++++- .../Plugin/Primitives/sha2_256.plc.golden | 4 +- plutus-tx/plutus-tx.cabal | 5 + plutus-tx/src/PlutusTx/Builtins.hs | 127 ++---------------- plutus-tx/src/PlutusTx/ByteString.hs | 7 + .../src/PlutusTx/ByteString/Instances.hs | 43 ++++++ plutus-tx/src/PlutusTx/ByteString/Internal.hs | 79 +++++++++++ plutus-tx/src/PlutusTx/Eq.hs | 6 + plutus-tx/src/PlutusTx/Ord.hs | 6 + plutus-tx/src/PlutusTx/Prelude.hs | 18 +-- plutus-tx/src/PlutusTx/String.hs | 47 +------ plutus-tx/src/PlutusTx/String/Instances.hs | 43 ++++++ plutus-tx/src/PlutusTx/String/Internal.hs | 44 ++++++ .../src/PlutusTx/String/Internal.hs-boot | 8 ++ 29 files changed, 466 insertions(+), 228 deletions(-) delete mode 100644 plutus-tx-plugin/test/Plugin/Errors/literalCaseBs.plc.golden create mode 100644 plutus-tx-plugin/test/Plugin/Errors/literalConcatenateBs.plc.golden create mode 100644 plutus-tx/src/PlutusTx/ByteString.hs create mode 100644 plutus-tx/src/PlutusTx/ByteString/Instances.hs create mode 100644 plutus-tx/src/PlutusTx/ByteString/Internal.hs create mode 100644 plutus-tx/src/PlutusTx/String/Instances.hs create mode 100644 plutus-tx/src/PlutusTx/String/Internal.hs create mode 100644 plutus-tx/src/PlutusTx/String/Internal.hs-boot diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Ada.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Ada.hs index 9db2e5e12e0..14f26800f8d 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Ada.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Ada.hs @@ -32,6 +32,7 @@ import Data.Fixed import Codec.Serialise.Class (Serialise) import Data.Aeson (FromJSON, ToJSON) +import qualified Data.ByteString as BS import Data.Tagged import Data.Text.Prettyprint.Doc.Extras import GHC.Generics (Generic) @@ -45,12 +46,12 @@ import qualified PlutusTx.Prelude as P {-# INLINABLE adaSymbol #-} -- | The 'CurrencySymbol' of the 'Ada' currency. adaSymbol :: CurrencySymbol -adaSymbol = TH.currencySymbol emptyByteString +adaSymbol = TH.currencySymbol BS.empty {-# INLINABLE adaToken #-} -- | The 'TokenName' of the 'Ada' currency. adaToken :: TokenName -adaToken = TH.tokenName emptyByteString +adaToken = TH.tokenName BS.empty -- | ADA, the special currency on the Cardano blockchain. The unit of Ada is Lovelace, and -- 1M Lovelace is one Ada. diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Bytes.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Bytes.hs index eef7634a363..ecf6f6c5d99 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Bytes.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Bytes.hs @@ -31,7 +31,6 @@ import Data.Text.Prettyprint.Doc.Extras (Pretty, PrettyShow (..)) import Data.Word (Word8) import GHC.Generics (Generic) import qualified PlutusTx as PlutusTx -import qualified PlutusTx.Builtins as Builtins import PlutusTx.Lift import qualified PlutusTx.Prelude as P @@ -62,13 +61,13 @@ fromHex = fmap LedgerBytes . asBSLiteral asBSLiteral :: BS.ByteString -> Either String BS.ByteString asBSLiteral = withBytes asBytes where - withBytes :: ([Word8] -> Either String [Word8]) -> P.ByteString -> Either String P.ByteString + withBytes :: ([Word8] -> Either String [Word8]) -> BS.ByteString -> Either String BS.ByteString withBytes f = fmap BS.pack . f . BS.unpack -- | 'Bultins.SizedByteString 32' with various useful JSON and -- servant instances for the Playground, and a convenient bridge -- type for PureScript. -newtype LedgerBytes = LedgerBytes { getLedgerBytes :: Builtins.ByteString } -- TODO: use strict bytestring +newtype LedgerBytes = LedgerBytes { getLedgerBytes :: BS.ByteString } -- TODO: use strict bytestring deriving stock (Eq, Ord, Generic) deriving newtype (Serialise, P.Eq, P.Ord, PlutusTx.IsData) deriving anyclass (JSON.ToJSONKey, JSON.FromJSONKey, NFData) diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Credential.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Credential.hs index e83b89a31b8..91c798a8fa4 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Credential.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Credential.hs @@ -21,6 +21,7 @@ module Plutus.V1.Ledger.Credential( import Codec.Serialise.Class (Serialise) import Control.DeepSeq (NFData) import Data.Aeson (FromJSON, ToJSON) +import qualified Data.ByteString as BS import Data.Hashable (Hashable) import Data.Text.Prettyprint.Doc (Pretty (..), (<+>)) import GHC.Generics (Generic) @@ -34,7 +35,7 @@ import qualified PlutusTx.Eq as PlutusTx -- | Staking credential used to assign rewards data StakingCredential - = StakingHash Builtins.ByteString + = StakingHash BS.ByteString | StakingPtr Integer Integer Integer -- NB: The fields should really be Word64 / Natural / Natural, but 'Integer' is our only integral type so we need to use it instead. deriving stock (Eq, Ord, Show, Generic) deriving anyclass (ToJSON, FromJSON, Serialise, Hashable, NFData) diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Crypto.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Crypto.hs index 13740a7cca4..3e81eda81cd 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Crypto.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Crypto.hs @@ -43,6 +43,7 @@ import qualified Data.Aeson as JSON import qualified Data.Aeson.Extras as JSON import qualified Data.ByteArray as BA import qualified Data.ByteString as BS +import qualified Data.ByteString.Hash as Hash import Data.Either.Extras (unsafeFromEither) import Data.Hashable (Hashable) import Data.String @@ -87,7 +88,7 @@ pubKeyHash :: PubKey -> PubKeyHash pubKeyHash (PubKey (LedgerBytes bs)) = -- this needs to be usable in on-chain code as well, so we have to -- INLINABLE & use the hash function from Builtins - PubKeyHash (Builtins.sha2_256 bs) + PubKeyHash (Hash.sha2 bs) -- | A cryptographic private key. newtype PrivateKey = PrivateKey { getPrivateKey :: LedgerBytes } @@ -99,7 +100,7 @@ newtype PrivateKey = PrivateKey { getPrivateKey :: LedgerBytes } makeLift ''PrivateKey -- | A message with a cryptographic signature. -newtype Signature = Signature { getSignature :: Builtins.ByteString } +newtype Signature = Signature { getSignature :: BS.ByteString } deriving stock (Eq, Ord, Generic) deriving newtype (P.Eq, P.Ord, Serialise, PlutusTx.IsData, NFData) deriving (Show, Pretty) via LedgerBytes diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs index 0b76081ec6b..793196b437f 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Scripts.hs @@ -63,6 +63,8 @@ import Data.Aeson (FromJSON, FromJSONKey, ToJSON import qualified Data.Aeson as JSON import qualified Data.Aeson.Extras as JSON import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +import qualified Data.ByteString.Hash as Hash import qualified Data.ByteString.Lazy as BSL import Data.Hashable (Hashable) import Data.String @@ -276,7 +278,7 @@ instance BA.ByteArrayAccess MonetaryPolicy where -- | Script runtime representation of a @Digest SHA256@. newtype ValidatorHash = - ValidatorHash Builtins.ByteString + ValidatorHash BS.ByteString deriving (IsString, Haskell.Show, Serialise, Pretty) via LedgerBytes deriving stock (Generic) deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, Hashable, IsData) @@ -284,7 +286,7 @@ newtype ValidatorHash = -- | Script runtime representation of a @Digest SHA256@. newtype DatumHash = - DatumHash Builtins.ByteString + DatumHash BS.ByteString deriving (IsString, Haskell.Show, Serialise, Pretty) via LedgerBytes deriving stock (Generic) deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, Hashable, IsData, NFData) @@ -292,7 +294,7 @@ newtype DatumHash = -- | Script runtime representation of a @Digest SHA256@. newtype RedeemerHash = - RedeemerHash Builtins.ByteString + RedeemerHash BS.ByteString deriving (IsString, Haskell.Show, Serialise, Pretty) via LedgerBytes deriving stock (Generic) deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, Hashable, IsData) @@ -300,17 +302,17 @@ newtype RedeemerHash = -- | Script runtime representation of a @Digest SHA256@. newtype MonetaryPolicyHash = - MonetaryPolicyHash Builtins.ByteString + MonetaryPolicyHash BS.ByteString deriving (IsString, Haskell.Show, Serialise, Pretty) via LedgerBytes deriving stock (Generic) deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, Hashable, IsData) deriving anyclass (FromJSON, ToJSON, ToJSONKey, FromJSONKey) datumHash :: Datum -> DatumHash -datumHash = DatumHash . Builtins.sha2_256 . BA.convert +datumHash = DatumHash . Hash.sha2 . BA.convert redeemerHash :: Redeemer -> RedeemerHash -redeemerHash = RedeemerHash . Builtins.sha2_256 . BA.convert +redeemerHash = RedeemerHash . Hash.sha2 . BA.convert validatorHash :: Validator -> ValidatorHash validatorHash vl = ValidatorHash $ BA.convert h' where diff --git a/plutus-ledger-api/src/Plutus/V1/Ledger/Value.hs b/plutus-ledger-api/src/Plutus/V1/Ledger/Value.hs index 9005219f9d0..4a5dbeb80ec 100644 --- a/plutus-ledger-api/src/Plutus/V1/Ledger/Value.hs +++ b/plutus-ledger-api/src/Plutus/V1/Ledger/Value.hs @@ -58,6 +58,7 @@ import Control.Monad (guard) import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey, (.:)) import qualified Data.Aeson as JSON import qualified Data.Aeson.Extras as JSON +import qualified Data.ByteString as BS import Data.Hashable (Hashable) import qualified Data.List (sortBy) import Data.String (IsString (fromString)) @@ -79,7 +80,7 @@ import qualified PlutusTx.Ord as Ord import PlutusTx.Prelude import PlutusTx.These -newtype CurrencySymbol = CurrencySymbol { unCurrencySymbol :: Builtins.ByteString } +newtype CurrencySymbol = CurrencySymbol { unCurrencySymbol :: BS.ByteString } deriving (IsString, Haskell.Show, Serialise, Pretty) via LedgerBytes deriving stock (Generic) deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, PlutusTx.IsData) @@ -115,11 +116,11 @@ currencyMPSHash :: CurrencySymbol -> MonetaryPolicyHash currencyMPSHash (CurrencySymbol h) = MonetaryPolicyHash h {-# INLINABLE currencySymbol #-} -currencySymbol :: ByteString -> CurrencySymbol +currencySymbol :: BS.ByteString -> CurrencySymbol currencySymbol = CurrencySymbol -- | ByteString of a name of a token, shown as UTF-8 string when possible -newtype TokenName = TokenName { unTokenName :: Builtins.ByteString } +newtype TokenName = TokenName { unTokenName :: BS.ByteString } deriving (Serialise) via LedgerBytes deriving stock (Generic) deriving newtype (Haskell.Eq, Haskell.Ord, Eq, Ord, PlutusTx.IsData) @@ -132,10 +133,10 @@ instance IsString TokenName where fromText :: Text -> TokenName fromText = TokenName . E.encodeUtf8 -fromTokenName :: (Builtins.ByteString -> r) -> (Text -> r) -> TokenName -> r +fromTokenName :: (BS.ByteString -> r) -> (Text -> r) -> TokenName -> r fromTokenName handleBytestring handleText (TokenName bs) = either (\_ -> handleBytestring bs) handleText $ E.decodeUtf8' bs -asBase16 :: Builtins.ByteString -> Text +asBase16 :: BS.ByteString -> Text asBase16 bs = Text.concat ["0x", JSON.encodeByteString bs] quoted :: Text -> Text @@ -176,7 +177,7 @@ instance FromJSON TokenName where makeLift ''TokenName {-# INLINABLE tokenName #-} -tokenName :: ByteString -> TokenName +tokenName :: BS.ByteString -> TokenName tokenName = TokenName -- | An asset class, identified by currency symbol and token name. diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 2d4ae046653..7127af44876 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -403,12 +403,20 @@ compileExpr e = withContextM 2 (sdToTxt $ "Compiling expr:" GHC.<+> GHC.ppr e) $ CompileContext {ccScopes=stack,ccBuiltinNameInfo=nameInfo} <- ask -- TODO: Maybe share this to avoid repeated lookups. Probably cheap, though. - (stringTyName, sbsName) <- case (Map.lookup ''Builtins.String nameInfo, Map.lookup 'String.stringToBuiltinString nameInfo) of - (Just t1, Just t2) -> pure $ (GHC.getName t1, GHC.getName t2) - _ -> throwPlain $ CompilationError "No info for String builtin" + (stringTyName, sbsName, bsTyName) <- case + ( Map.lookup ''Builtins.String nameInfo + , Map.lookup 'String.stringToBuiltinString nameInfo + , Map.lookup ''Builtins.ByteString nameInfo + ) of + (Just t1, Just t2, Just t3) -> pure $ (GHC.getName t1, GHC.getName t2, GHC.getName t3) + _ -> throwPlain $ CompilationError "No info for String builtin" let top = NE.head stack case e of + -- 'fromString' invocation at the builtin ByteString type + (strip -> GHC.Var (GHC.idDetails -> GHC.ClassOpId cls)) `GHC.App` GHC.Type (GHC.tyConAppTyCon_maybe -> Just tc) `GHC.App` _ `GHC.App` (strip -> stringExprContent -> Just bs) + | GHC.getName cls == GHC.isStringClassName, GHC.getName tc == bsTyName -> do + pure $ PIR.Constant () $ PLC.someValue bs -- See Note [String literals] -- 'fromString' invocation at the builtin String type (strip -> GHC.Var (GHC.idDetails -> GHC.ClassOpId cls)) `GHC.App` GHC.Type (GHC.tyConAppTyCon_maybe -> Just tc) `GHC.App` _ `GHC.App` (strip -> stringExprContent -> Just bs) diff --git a/plutus-tx-plugin/test/Lift/Spec.hs b/plutus-tx-plugin/test/Lift/Spec.hs index 84370689c0f..d49c9aae4ec 100644 --- a/plutus-tx-plugin/test/Lift/Spec.hs +++ b/plutus-tx-plugin/test/Lift/Spec.hs @@ -24,9 +24,6 @@ Lift.makeLift ''MyPolyData data NestedRecord = NestedRecord { unNested :: Maybe (Integer, Integer) } Lift.makeLift ''NestedRecord -data WrappedBS = WrappedBS { unWrap :: Builtins.ByteString } -Lift.makeLift ''WrappedBS - newtype NewtypeInt = NewtypeInt { unNt :: Integer } Lift.makeLift ''NewtypeInt @@ -57,7 +54,6 @@ tests = testNested "Lift" [ , goldenUPlc "list" (Lift.liftProgramDef ([1]::[Integer])) , goldenUEval "listInterop" [ getPlc listMatch, Lift.liftProgramDef ([1]::[Integer]) ] , goldenUPlc "nested" (Lift.liftProgramDef (NestedRecord (Just (1, 2)))) - , goldenUPlc "bytestring" (Lift.liftProgramDef (WrappedBS "hello")) , goldenUPlc "newtypeInt" (Lift.liftProgramDef (NewtypeInt 1)) , goldenUPlc "newtypeInt2" (Lift.liftProgramDef (Newtype2 $ NewtypeInt 1)) , goldenUPlc "newtypeInt3" (Lift.liftProgramDef (Newtype3 $ Newtype2 $ NewtypeInt 1)) diff --git a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs index fb8bbbd22e4..0b6b71a02ec 100644 --- a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs @@ -38,7 +38,7 @@ errors = testNested "Errors" [ , goldenUPlcCatch "recursiveNewtype" recursiveNewtype , goldenUPlcCatch "mutualRecursionUnfoldingsLocal" mutualRecursionUnfoldingsLocal , goldenUPlcCatch "literalCaseInt" literalCaseInt - , goldenUPlcCatch "literalCaseBs" literalCaseBs + , goldenUPlcCatch "literalConcatenateBs" literalConcatenateBs , goldenUPlcCatch "literalCaseOther" literalCaseOther ] @@ -71,8 +71,8 @@ mutualRecursionUnfoldingsLocal = plc (Proxy @"mutualRecursionUnfoldingsLocal") ( literalCaseInt :: CompiledCode (Integer -> Integer) literalCaseInt = plc (Proxy @"literalCaseInt") (\case { 1 -> 2; x -> x}) -literalCaseBs :: CompiledCode (Builtins.ByteString -> Builtins.ByteString) -literalCaseBs = plc (Proxy @"literalCaseBs") (\x -> case x of { "abc" -> ""; x -> x}) +literalConcatenateBs :: CompiledCode (Builtins.ByteString -> Builtins.ByteString) +literalConcatenateBs = plc (Proxy @"literalConcatenateBs") (\x -> Builtins.concatenate "hello" x) data AType = AType diff --git a/plutus-tx-plugin/test/Plugin/Errors/literalCaseBs.plc.golden b/plutus-tx-plugin/test/Plugin/Errors/literalCaseBs.plc.golden deleted file mode 100644 index 7851bf614b7..00000000000 --- a/plutus-tx-plugin/test/Plugin/Errors/literalCaseBs.plc.golden +++ /dev/null @@ -1 +0,0 @@ -Error: Unsupported feature: Use of Haskell ByteString equality, possibly via the Haskell Eq typeclass \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Errors/literalConcatenateBs.plc.golden b/plutus-tx-plugin/test/Plugin/Errors/literalConcatenateBs.plc.golden new file mode 100644 index 00000000000..b6988d26067 --- /dev/null +++ b/plutus-tx-plugin/test/Plugin/Errors/literalConcatenateBs.plc.golden @@ -0,0 +1,3 @@ +(program 1.0.0 + (lam x_i0 [ [ (builtin concatenate) (con bytestring #68656c6c6f) ] x_i1 ]) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs index 99f2e879d01..5e5cbc2beaf 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs @@ -45,13 +45,12 @@ primitives = testNested "Primitives" [ , goldenPir "ifThenElse" ifThenElse , goldenUEval "ifThenElseApply" [ toUPlc ifThenElse, toUPlc int, toUPlc int2 ] , goldenPir "emptyByteString" emptyByteString - , goldenUEval "emptyByteStringApply" [ getPlc emptyByteString, liftProgram Builtins.emptyByteString ] + , goldenUEval "emptyByteStringApply" [ getPlc emptyByteString, liftProgram ("" :: String) ] + , goldenPir "sha2_256" sha2 , goldenPir "bytestring" bytestring - , goldenUEval "bytestringApply" [ getPlc bytestring, liftProgram ("hello"::Builtins.ByteString) ] - , goldenUEval "sha2_256" [ getPlc sha2, liftProgram ("hello" :: Builtins.ByteString)] - , goldenUEval "equalsByteString" [ getPlc bsEquals, liftProgram ("hello" :: Builtins.ByteString), liftProgram ("hello" :: Builtins.ByteString)] - , goldenUEval "ltByteString" [ getPlc bsLt, liftProgram ("hello" :: Builtins.ByteString), liftProgram ("world" :: Builtins.ByteString)] - , goldenUEval "decodeUtf8" [ getPlc bsDecode, liftProgram ("hello" :: Builtins.ByteString)] + , goldenPir "equalsByteString" bsEquals + , goldenPir "ltByteString" bsLt + , goldenPir "decodeUtf8" bsDecode , goldenPir "verify" verify , goldenPir "trace" trace , goldenPir "stringLiteral" stringLiteral @@ -106,23 +105,23 @@ errorPlc = plc (Proxy @"errorPlc") (Builtins.error @Integer) ifThenElse :: CompiledCode (Integer -> Integer -> Integer) ifThenElse = plc (Proxy @"ifThenElse") (\(x::Integer) (y::Integer) -> if Builtins.equalsInteger x y then x else y) -emptyByteString :: CompiledCode (Builtins.ByteString -> Builtins.ByteString) -emptyByteString = plc (Proxy @"emptyByteString") (\(x :: Builtins.ByteString) -> x) +emptyByteString :: CompiledCode (String -> Builtins.ByteString) +emptyByteString = plc (Proxy @"emptyByteString") (\(x :: String) -> Builtins.encodeUtf8 (P.stringToBuiltinString x)) bytestring :: CompiledCode (Builtins.ByteString -> Builtins.ByteString) bytestring = plc (Proxy @"bytestring") (\(x::Builtins.ByteString) -> x) -sha2 :: CompiledCode (Builtins.ByteString -> Builtins.ByteString) -sha2 = plc (Proxy @"sha2") (\(x :: Builtins.ByteString) -> Builtins.sha2_256 x) +sha2 :: CompiledCode Builtins.ByteString +sha2 = plc (Proxy @"sha2") (Builtins.sha2_256 "hello") -bsEquals :: CompiledCode (Builtins.ByteString -> Builtins.ByteString -> Bool) -bsEquals = plc (Proxy @"bs32Equals") (\(x :: Builtins.ByteString) (y :: Builtins.ByteString) -> Builtins.equalsByteString x y) +bsEquals :: CompiledCode Bool +bsEquals = plc (Proxy @"bs32Equals") (Builtins.equalsByteString ("hello" :: Builtins.ByteString) ("hello" :: Builtins.ByteString)) -bsLt :: CompiledCode (Builtins.ByteString -> Builtins.ByteString -> Bool) -bsLt = plc (Proxy @"bsLt") (\(x :: Builtins.ByteString) (y :: Builtins.ByteString) -> Builtins.lessThanByteString x y) +bsLt :: CompiledCode Bool +bsLt = plc (Proxy @"bsLt") (Builtins.lessThanByteString ("hello" :: Builtins.ByteString) ("world" :: Builtins.ByteString)) -bsDecode :: CompiledCode (Builtins.ByteString -> Builtins.String) -bsDecode = plc (Proxy @"bsDecode") (\(x :: Builtins.ByteString) -> Builtins.decodeUtf8 x) +bsDecode :: CompiledCode Builtins.String +bsDecode = plc (Proxy @"bsDecode") (Builtins.decodeUtf8 ("hello" :: Builtins.ByteString)) verify :: CompiledCode (Builtins.ByteString -> Builtins.ByteString -> Builtins.ByteString -> Bool) verify = plc (Proxy @"verify") (\(x::Builtins.ByteString) (y::Builtins.ByteString) (z::Builtins.ByteString) -> Builtins.verifySignature x y z) diff --git a/plutus-tx-plugin/test/Plugin/Primitives/decodeUtf8.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/decodeUtf8.plc.golden index b5b46ba8829..a1e3c410ca8 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/decodeUtf8.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/decodeUtf8.plc.golden @@ -1 +1 @@ -(con string "hello") \ No newline at end of file +(program [ (builtin decodeUtf8) (con bytestring #68656c6c6f) ]) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/emptyByteString.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/emptyByteString.plc.golden index 6a786e82f7a..5b33cb570d1 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/emptyByteString.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/emptyByteString.plc.golden @@ -1 +1,68 @@ -(program (lam ds (con bytestring) ds)) \ No newline at end of file +(program + (let + (rec) + (datatypebind + (datatype + (tyvardecl List (fun (type) (type))) + (tyvardecl a (type)) + Nil_match + (vardecl Nil [List a]) (vardecl Cons (fun a (fun [List a] [List a]))) + ) + ) + (let + (nonrec) + (datatypebind + (datatype (tyvardecl Unit (type)) Unit_match (vardecl Unit Unit)) + ) + (let + (rec) + (termbind + (strict) + (vardecl go (fun [List (con char)] (con string))) + (lam + ds + [List (con char)] + [ + [ + [ + { [ { Nil_match (con char) } ds ] (fun Unit (con string)) } + (lam thunk Unit (con string "")) + ] + (lam + x + (con char) + (lam + xs + [List (con char)] + (lam + thunk + Unit + [ + [ (builtin append) [ (builtin charToString) x ] ] + [ go xs ] + ] + ) + ) + ) + ] + Unit + ] + ) + ) + (let + (nonrec) + (termbind + (nonstrict) + (vardecl stringToBuiltinString (fun [List (con char)] (con string))) + go + ) + (lam + ds + [List (con char)] + [ (builtin encodeUtf8) [ stringToBuiltinString ds ] ] + ) + ) + ) + ) + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden index 0203d123423..604485de13f 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/equalsByteString.plc.golden @@ -1 +1,40 @@ -(delay (lam case_True_9 (lam case_False_10 case_True_9))) \ No newline at end of file +(program + (let + (nonrec) + (datatypebind + (datatype + (tyvardecl Bool (type)) + + Bool_match + (vardecl True Bool) (vardecl False Bool) + ) + ) + (termbind + (strict) + (vardecl + equalsByteString (fun (con bytestring) (fun (con bytestring) Bool)) + ) + (lam + arg + (con bytestring) + (lam + arg + (con bytestring) + (let + (nonrec) + (termbind + (strict) + (vardecl b (con bool)) + [ [ (builtin equalsByteString) arg ] arg ] + ) + [ [ [ { (builtin ifThenElse) Bool } b ] True ] False ] + ) + ) + ) + ) + [ + [ equalsByteString (con bytestring #68656c6c6f) ] + (con bytestring #68656c6c6f) + ] + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden index 0203d123423..60d844f7ca3 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/ltByteString.plc.golden @@ -1 +1,40 @@ -(delay (lam case_True_9 (lam case_False_10 case_True_9))) \ No newline at end of file +(program + (let + (nonrec) + (datatypebind + (datatype + (tyvardecl Bool (type)) + + Bool_match + (vardecl True Bool) (vardecl False Bool) + ) + ) + (termbind + (strict) + (vardecl + lessThanByteString (fun (con bytestring) (fun (con bytestring) Bool)) + ) + (lam + arg + (con bytestring) + (lam + arg + (con bytestring) + (let + (nonrec) + (termbind + (strict) + (vardecl b (con bool)) + [ [ (builtin lessThanByteString) arg ] arg ] + ) + [ [ [ { (builtin ifThenElse) Bool } b ] True ] False ] + ) + ) + ) + ) + [ + [ lessThanByteString (con bytestring #68656c6c6f) ] + (con bytestring #776f726c64) + ] + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/sha2_256.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/sha2_256.plc.golden index da957a9a88d..254d0163bed 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/sha2_256.plc.golden +++ b/plutus-tx-plugin/test/Plugin/Primitives/sha2_256.plc.golden @@ -1,3 +1 @@ -(con - bytestring #2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824 -) \ No newline at end of file +(program [ (builtin sha2_256) (con bytestring #68656c6c6f) ]) \ No newline at end of file diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index f589aad75be..1c6e13ff33d 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -41,6 +41,9 @@ library PlutusTx.Evaluation PlutusTx.Applicative PlutusTx.Bool + PlutusTx.ByteString + PlutusTx.ByteString.Internal + PlutusTx.ByteString.Instances PlutusTx.IsData PlutusTx.IsData.Class PlutusTx.Eq @@ -67,6 +70,8 @@ library PlutusTx.Plugin.Utils PlutusTx.Utils PlutusTx.String + PlutusTx.String.Internal + PlutusTx.String.Instances other-modules: PlutusTx.IsData.Instances PlutusTx.IsData.TH diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 806eb36409a..f1f6aa9824d 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -6,19 +6,10 @@ {-# OPTIONS_GHC -O0 #-} -- | Primitive names and functions for working with Plutus Core builtins. module PlutusTx.Builtins ( - -- * Bytestring builtins - ByteString - , concatenate - , takeByteString - , dropByteString - , emptyByteString - , equalsByteString - , lessThanByteString - , greaterThanByteString - , sha2_256 - , sha3_256 - , verifySignature - , decodeUtf8 + -- * Bytestrings + module PlutusTx.ByteString + -- * Strings + , module PlutusTx.String -- * Integer builtins , addInteger , subtractInteger @@ -36,89 +27,16 @@ module PlutusTx.Builtins ( , error -- * Data , Data (..) - -- * Strings - , String - , appendString - , emptyString - , charToString - , equalsString - , encodeUtf8 -- * Tracing , trace ) where -import qualified Crypto -import Data.ByteString as BS -import qualified Data.ByteString.Hash as Hash -import Data.Maybe (fromMaybe) -import Prelude hiding (String, error) +import Prelude hiding (String, error) +import PlutusTx.ByteString import PlutusTx.Data -import PlutusTx.Utils (mustBeReplaced) - -{- Note [Builtin name definitions] -The builtins here have definitions so they can be used in off-chain code too. - -However they *must* be replaced by the compiler when used in Plutus Tx code, so -in particular they must *not* be inlined, otherwise we can't spot them to replace -them. --} - -{-# NOINLINE concatenate #-} --- | Concatenates two 'ByteString's. -concatenate :: ByteString -> ByteString -> ByteString -concatenate = BS.append - -{-# NOINLINE takeByteString #-} --- | Returns the n length prefix of a 'ByteString'. -takeByteString :: Integer -> ByteString -> ByteString -takeByteString n = BS.take (fromIntegral n) - -{-# NOINLINE dropByteString #-} --- | Returns the suffix of a 'ByteString' after n elements. -dropByteString :: Integer -> ByteString -> ByteString -dropByteString n = BS.drop (fromIntegral n) - -{-# NOINLINE emptyByteString #-} --- | An empty 'ByteString'. -emptyByteString :: ByteString -emptyByteString = BS.empty - -{-# NOINLINE sha2_256 #-} --- | The SHA2-256 hash of a 'ByteString' -sha2_256 :: ByteString -> ByteString -sha2_256 = Hash.sha2 - -{-# NOINLINE sha3_256 #-} --- | The SHA3-256 hash of a 'ByteString' -sha3_256 :: ByteString -> ByteString -sha3_256 = Hash.sha3 - -{-# NOINLINE verifySignature #-} --- | Verify that the signature is a signature of the message by the public key. -verifySignature :: ByteString -> ByteString -> ByteString -> Bool -verifySignature pubKey message signature = - fromMaybe False (Crypto.verifySignature pubKey message signature) - -{-# NOINLINE equalsByteString #-} --- | Check if two 'ByteString's are equal. -equalsByteString :: ByteString -> ByteString -> Bool -equalsByteString = (==) - -{-# NOINLINE lessThanByteString #-} --- | Check if one 'ByteString' is less than another. -lessThanByteString :: ByteString -> ByteString -> Bool -lessThanByteString = (<) - -{-# NOINLINE greaterThanByteString #-} --- | Check if one 'ByteString' is greater than another. -greaterThanByteString :: ByteString -> ByteString -> Bool -greaterThanByteString = (>) - -{-# NOINLINE decodeUtf8 #-} --- | Converts a ByteString to a String. -decodeUtf8 :: ByteString -> String -decodeUtf8 = mustBeReplaced "decodeUtf8" +import PlutusTx.String +import PlutusTx.Utils (mustBeReplaced) {-# NOINLINE addInteger #-} -- | Add two 'Integer's. @@ -204,36 +122,7 @@ it is a problem. So we just expose the delayed version as the builtin. error :: () -> a error = mustBeReplaced "error" --- Note: IsString instance is in 'Prelude.hs' --- | An opaque type representing Plutus Core strings. -data String - -{-# NOINLINE appendString #-} --- | Append two 'String's. -appendString :: String -> String -> String -appendString = mustBeReplaced "appendString" - -{-# NOINLINE emptyString #-} --- | An empty 'String'. -emptyString :: String -emptyString = mustBeReplaced "emptyString" - -{-# NOINLINE charToString #-} --- | Turn a 'Char' into a 'String'. -charToString :: Char -> String -charToString = mustBeReplaced "charToString" - -{-# NOINLINE equalsString #-} --- | Check if two strings are equal -equalsString :: String -> String -> Bool -equalsString = mustBeReplaced "equalsString" - {-# NOINLINE trace #-} -- | Logs the given 'String' to the evaluation log. trace :: String -> () trace _ = () --mustBeReplaced "trace" - -{-# NOINLINE encodeUtf8 #-} --- | Convert a String into a ByteString. -encodeUtf8 :: String -> ByteString -encodeUtf8 = mustBeReplaced "encodeUtf8" diff --git a/plutus-tx/src/PlutusTx/ByteString.hs b/plutus-tx/src/PlutusTx/ByteString.hs new file mode 100644 index 00000000000..28e79d4a5df --- /dev/null +++ b/plutus-tx/src/PlutusTx/ByteString.hs @@ -0,0 +1,7 @@ +module PlutusTx.ByteString + ( module PlutusTx.ByteString.Internal + , module PlutusTx.ByteString.Instances + ) where + +import PlutusTx.ByteString.Instances +import PlutusTx.ByteString.Internal diff --git a/plutus-tx/src/PlutusTx/ByteString/Instances.hs b/plutus-tx/src/PlutusTx/ByteString/Instances.hs new file mode 100644 index 00000000000..1232a0239fa --- /dev/null +++ b/plutus-tx/src/PlutusTx/ByteString/Instances.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +-- For the 'IsString' instance +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +module PlutusTx.ByteString.Instances (stringToBuiltinByteString) where + +import Data.String (IsString (..)) +import PlutusTx.ByteString.Internal as Plutus +import qualified PlutusTx.String as String + +import qualified GHC.Magic as Magic +{- Note [noinline hack] +For some functions we have two conflicting desires: +- We want to have the unfolding available for the plugin. +- We don't want the function to *actually* get inlined before the plugin runs, since we rely +on being able to see the original function for some reason. + +'INLINABLE' achieves the first, but may cause the function to be inlined too soon. + +We can solve this at specific call sites by using the 'noinline' magic function from +GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if +that function is compiled later into the body of another function. + +We do therefore need to handle 'noinline' in the plugin, as it itself does not have +an unfolding. +-} + +-- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents +-- the unfoldings from going in. So we just stick it here. Fiddly. +instance IsString ByteString where + -- Try and make sure the dictionary selector goes away, it's simpler to match on + -- the application of 'stringToBuiltinByteString' + {-# INLINE fromString #-} + -- See Note [noinline hack] + fromString = Magic.noinline stringToBuiltinByteString + +{-# INLINABLE stringToBuiltinByteString #-} +stringToBuiltinByteString :: String -> ByteString +stringToBuiltinByteString = String.encodeUtf8 . String.stringToBuiltinString diff --git a/plutus-tx/src/PlutusTx/ByteString/Internal.hs b/plutus-tx/src/PlutusTx/ByteString/Internal.hs new file mode 100644 index 00000000000..5df349ab71d --- /dev/null +++ b/plutus-tx/src/PlutusTx/ByteString/Internal.hs @@ -0,0 +1,79 @@ +-- This ensures that we don't put *anything* about these functions into the interface +-- file, otherwise GHC can be clever about the ones that are always error, even though +-- they're NOINLINE! +{-# OPTIONS_GHC -O0 #-} +module PlutusTx.ByteString.Internal + ( ByteString + , concatenate + , takeByteString + , dropByteString + , emptyByteString + , sha2_256 + , sha3_256 + , verifySignature + , equalsByteString + , lessThanByteString + , greaterThanByteString + , decodeUtf8 + ) where + +import {-# SOURCE #-} PlutusTx.String.Internal as String +import PlutusTx.Utils (mustBeReplaced) + +-- | An opaque type representing Plutus Core ByteStrings. +data ByteString + +{-# NOINLINE concatenate #-} +-- | Concatenates two 'ByteString's. +concatenate :: ByteString -> ByteString -> ByteString +concatenate = mustBeReplaced "concatenate" + +{-# NOINLINE takeByteString #-} +-- | Returns the n length prefix of a 'ByteString'. +takeByteString :: Integer -> ByteString -> ByteString +takeByteString = mustBeReplaced "takeByteString" + +{-# NOINLINE dropByteString #-} +-- | Returns the suffix of a 'ByteString' after n elements. +dropByteString :: Integer -> ByteString -> ByteString +dropByteString = mustBeReplaced "dropByteString" + +{-# NOINLINE emptyByteString #-} +-- | An empty 'ByteString'. +emptyByteString :: ByteString +emptyByteString = mustBeReplaced "emptyByteString" + +{-# NOINLINE sha2_256 #-} +-- | The SHA2-256 hash of a 'ByteString' +sha2_256 :: ByteString -> ByteString +sha2_256 = mustBeReplaced "sha2_256" + +{-# NOINLINE sha3_256 #-} +-- | The SHA3-256 hash of a 'ByteString' +sha3_256 :: ByteString -> ByteString +sha3_256 = mustBeReplaced "sha3_256" + +{-# NOINLINE verifySignature #-} +-- | Verify that the signature is a signature of the message by the public key. +verifySignature :: ByteString -> ByteString -> ByteString -> Bool +verifySignature = mustBeReplaced "verifySignature" + +{-# NOINLINE equalsByteString #-} +-- | Check if two 'ByteString's are equal. +equalsByteString :: ByteString -> ByteString -> Bool +equalsByteString = mustBeReplaced "equalsByteString" + +{-# NOINLINE lessThanByteString #-} +-- | Check if one 'ByteString' is less than another. +lessThanByteString :: ByteString -> ByteString -> Bool +lessThanByteString = mustBeReplaced "lessThanByteString" + +{-# NOINLINE greaterThanByteString #-} +-- | Check if one 'ByteString' is greater than another. +greaterThanByteString :: ByteString -> ByteString -> Bool +greaterThanByteString = mustBeReplaced "greaterThanByteString" + +{-# NOINLINE decodeUtf8 #-} +-- | Converts a ByteString to a String. +decodeUtf8 :: ByteString -> String.String +decodeUtf8 = mustBeReplaced "decodeUtf8" diff --git a/plutus-tx/src/PlutusTx/Eq.hs b/plutus-tx/src/PlutusTx/Eq.hs index 934877dd865..739d450b3e4 100644 --- a/plutus-tx/src/PlutusTx/Eq.hs +++ b/plutus-tx/src/PlutusTx/Eq.hs @@ -1,11 +1,13 @@ {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Eq (Eq(..), (/=)) where +import qualified Data.ByteString as BS import PlutusTx.Bool import qualified PlutusTx.Builtins as Builtins import PlutusTx.Data import Prelude hiding (Eq (..), not, (&&)) +import qualified Prelude as Haskell {-# ANN module ("HLint: ignore"::String) #-} @@ -35,6 +37,10 @@ instance Eq Builtins.String where {-# INLINABLE (==) #-} (==) = Builtins.equalsString +instance Eq BS.ByteString where + {-# INLINABLE (==) #-} + (==) = (Haskell.==) + instance Eq a => Eq [a] where {-# INLINABLE (==) #-} [] == [] = True diff --git a/plutus-tx/src/PlutusTx/Ord.hs b/plutus-tx/src/PlutusTx/Ord.hs index 2b046e087c0..f46de50448d 100644 --- a/plutus-tx/src/PlutusTx/Ord.hs +++ b/plutus-tx/src/PlutusTx/Ord.hs @@ -1,12 +1,14 @@ {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Ord (Ord(..), Max (..), Min (..), Ordering(..)) where +import qualified Data.ByteString as BS import qualified PlutusTx.Builtins as Builtins import PlutusTx.Data import PlutusTx.Eq import PlutusTx.Semigroup import Prelude hiding (Eq (..), Ord (..), Semigroup (..)) +import qualified Prelude as Haskell {-# ANN module ("HLint: ignore"::String) #-} @@ -61,6 +63,10 @@ instance Ord Builtins.ByteString where {-# INLINABLE compare #-} compare l r = if Builtins.lessThanByteString l r then LT else if Builtins.equalsByteString l r then EQ else GT +instance Ord BS.ByteString where + {-# INLINABLE compare #-} + compare = Haskell.compare + instance Ord a => Ord [a] where {-# INLINABLE compare #-} compare [] [] = EQ diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index 48532af6f8f..3c6dd84c70d 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/plutus-tx/src/PlutusTx/Prelude.hs @@ -57,15 +57,7 @@ module PlutusTx.Prelude ( dropWhile, zipWith, -- * ByteStrings - ByteString, - takeByteString, - dropByteString, - concatenate, - emptyByteString, - -- * Hashes and Signatures - sha2_256, - sha3_256, - verifySignature, + module ByteString, -- * Rational numbers Rational, (%), @@ -78,10 +70,8 @@ module PlutusTx.Prelude ( import Data.String (IsString (..)) import PlutusTx.Applicative as Applicative import PlutusTx.Bool as Bool -import PlutusTx.Builtins (ByteString, concatenate, dropByteString, emptyByteString, equalsByteString, - greaterThanByteString, lessThanByteString, sha2_256, sha3_256, takeByteString, - verifySignature) import qualified PlutusTx.Builtins as Builtins +import PlutusTx.ByteString as ByteString import PlutusTx.Either as Either import PlutusTx.Eq as Eq import PlutusTx.Foldable as Foldable @@ -102,10 +92,10 @@ import Prelude as Prelude hiding (Applicative (..), Eq (. either, elem, error, filter, fst, head, id, length, map, mapM_, max, maybe, min, not, notElem, null, or, quotRem, reverse, round, sequence, snd, take, zip, (!!), ($), (&&), (++), (<$>), (||)) -import Prelude as Prelude (maximum, minimum) +import qualified Prelude as Haskell -- this module does lots of weird stuff deliberately -{-# ANN module ("HLint: ignore"::String) #-} +{-# ANN module ("HLint: ignore"::Haskell.String) #-} -- $prelude -- The PlutusTx Prelude is a replacement for the Haskell Prelude that works diff --git a/plutus-tx/src/PlutusTx/String.hs b/plutus-tx/src/PlutusTx/String.hs index 65f2db74ca0..47bd11f6263 100644 --- a/plutus-tx/src/PlutusTx/String.hs +++ b/plutus-tx/src/PlutusTx/String.hs @@ -1,42 +1,7 @@ --- For the 'IsString' instance -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +module PlutusTx.String + ( module PlutusTx.String.Internal + , module PlutusTx.String.Instances + ) where -module PlutusTx.String (stringToBuiltinString) where - -import qualified PlutusTx.Builtins as Builtins - -import Data.String (IsString (..)) - -import qualified GHC.Magic as Magic -{- Note [noinline hack] -For some functions we have two conflicting desires: -- We want to have the unfolding available for the plugin. -- We don't want the function to *actually* get inlined before the plugin runs, since we rely -on being able to see the original function for some reason. - -'INLINABLE' achieves the first, but may cause the function to be inlined too soon. - -We can solve this at specific call sites by using the 'noinline' magic function from -GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if -that function is compiled later into the body of another function. - -We do therefore need to handle 'noinline' in the plugin, as it itself does not have -an unfolding. --} - --- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents --- the unfoldings from going in. So we just stick it here. Fiddly. -instance IsString Builtins.String where - -- Try and make sure the dictionary selector goes away, it's simpler to match on - -- the application of 'stringToBuiltinString' - {-# INLINE fromString #-} - -- See Note [noinline hack] - fromString = Magic.noinline stringToBuiltinString - -{-# INLINABLE stringToBuiltinString #-} -stringToBuiltinString :: String -> Builtins.String -stringToBuiltinString = go - where - go [] = Builtins.emptyString - go (x:xs) = Builtins.charToString x `Builtins.appendString` go xs +import PlutusTx.String.Instances +import PlutusTx.String.Internal diff --git a/plutus-tx/src/PlutusTx/String/Instances.hs b/plutus-tx/src/PlutusTx/String/Instances.hs new file mode 100644 index 00000000000..354e0233105 --- /dev/null +++ b/plutus-tx/src/PlutusTx/String/Instances.hs @@ -0,0 +1,43 @@ +-- For the 'IsString' instance +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +module PlutusTx.String.Instances (stringToBuiltinString) where + +import PlutusTx.String.Internal as Plutus + +import qualified Data.String as Haskell (IsString (..), String) + +import qualified GHC.Magic as Magic + +{- Note [noinline hack] +For some functions we have two conflicting desires: +- We want to have the unfolding available for the plugin. +- We don't want the function to *actually* get inlined before the plugin runs, since we rely +on being able to see the original function for some reason. + +'INLINABLE' achieves the first, but may cause the function to be inlined too soon. + +We can solve this at specific call sites by using the 'noinline' magic function from +GHC. This stops GHC from inlining it. As a bonus, it also won't be inlined if +that function is compiled later into the body of another function. + +We do therefore need to handle 'noinline' in the plugin, as it itself does not have +an unfolding. +-} + +-- We can't put this in `Builtins.hs`, since that force `O0` deliberately, which prevents +-- the unfoldings from going in. So we just stick it here. Fiddly. +instance Haskell.IsString Plutus.String where + -- Try and make sure the dictionary selector goes away, it's simpler to match on + -- the application of 'stringToBuiltinString' + {-# INLINE fromString #-} + -- See Note [noinline hack] + fromString = Magic.noinline stringToBuiltinString + +{-# INLINABLE stringToBuiltinString #-} +stringToBuiltinString :: Haskell.String -> Plutus.String +stringToBuiltinString = go + where + go [] = emptyString + go (x:xs) = charToString x `appendString` go xs diff --git a/plutus-tx/src/PlutusTx/String/Internal.hs b/plutus-tx/src/PlutusTx/String/Internal.hs new file mode 100644 index 00000000000..7e4a0bd081c --- /dev/null +++ b/plutus-tx/src/PlutusTx/String/Internal.hs @@ -0,0 +1,44 @@ +-- This ensures that we don't put *anything* about these functions into the interface +-- file, otherwise GHC can be clever about the ones that are always error, even though +-- they're NOINLINE! +{-# OPTIONS_GHC -O0 #-} +module PlutusTx.String.Internal + ( String + , appendString + , emptyString + , charToString + , equalsString + , encodeUtf8 + ) where + +import PlutusTx.ByteString.Internal as BS +import PlutusTx.Utils (mustBeReplaced) +import qualified Prelude as Haskell + +-- | An opaque type representing Plutus Core strings. +data String + +{-# NOINLINE appendString #-} +-- | Append two 'String's. +appendString :: String -> String -> String +appendString = mustBeReplaced "appendString" + +{-# NOINLINE emptyString #-} +-- | An empty 'String'. +emptyString :: String +emptyString = mustBeReplaced "emptyString" + +{-# NOINLINE charToString #-} +-- | Turn a 'Char' into a 'String'. +charToString :: Haskell.Char -> String +charToString = mustBeReplaced "charToString" + +{-# NOINLINE equalsString #-} +-- | Check if two strings are equal +equalsString :: String -> String -> Haskell.Bool +equalsString = mustBeReplaced "equalsString" + +{-# NOINLINE encodeUtf8 #-} +-- | Convert a String into a ByteString. +encodeUtf8 :: String -> BS.ByteString +encodeUtf8 = mustBeReplaced "encodeUtf8" diff --git a/plutus-tx/src/PlutusTx/String/Internal.hs-boot b/plutus-tx/src/PlutusTx/String/Internal.hs-boot new file mode 100644 index 00000000000..881ab6a8ad4 --- /dev/null +++ b/plutus-tx/src/PlutusTx/String/Internal.hs-boot @@ -0,0 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module PlutusTx.String.Internal + ( String + ) where + +-- | An opaque type representing Plutus Core strings. +data String